content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE LinearTypes #-}
  {-# LANGUAGE QualifiedDo #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  module Directory.Server where
  
  import Control.Concurrent
  import Control.Monad (guard, join)
  import qualified Control.Monad.Catch as Catch
  import Control.Monad.Reader (ask, asks)
  import qualified Control.Functor.Linear as Linear
  import Control.Monad.Logger
  import Data.Int
  import Data.IORef
  import Data.List (isPrefixOf)
  import Data.Text (Text)
  import qualified Data.Text as Text
  import Foreign.JNI.Safe
  import qualified Foreign.JNI.Types as NonLinear -- Brings J into scope
  import qualified Foreign.JNI.Unsafe as Unsafe
  import Language.Java.Inline.Safe
  import Language.Java.Safe
  import Directory.Server.Monad.Classes
  import Directory.Server.Http
  import Directory.Server.Monad
  import Prelude
  import Prelude.Linear (Ur(..))
  import System.FilePath
  import System.Posix.Signals (Handler(Catch), Signal, installHandler, sigINT, sigTERM)
  
  
  server :: Int -> LServer ()
  server port = Linear.do
      Ur mvStop <- liftPreludeIOU newEmptyMVar
      Ur env <- liftU ask
      UnsafeUnrestrictedReference httpServer <-
        startHttpServer (fromIntegral port) (runHandler env)
      lift
        (logInfoN $ Text.pack $
           "Started server on port " ++ show port ++ "."
        )
      liftPreludeIO
        (withSignalHandlers
          (stopServer mvStop httpServer)
          (takeMVar mvStop)
        )
       `finally`
          (lift $ logInfoN $ Text.pack $
             "Server on port " ++ show port ++ " terminated."
          )
      where
        stopServer :: MVar () -> JHttpServer -> IO ()
        stopServer mvStop httpServer =
          runInBoundThread $ Unsafe.runInAttachedThread $ do
            stopHttpServer httpServer
            Unsafe.deleteGlobalRef httpServer
            putMVar mvStop ()
  
        runHandler :: Environment -> JHttpExchange -> IO ()
        runHandler env exchange = runLServer env (handleRequest exchange)
  
  data Response = Response
    { responseCode :: Int32
    , responseMsg :: Text
    }
  
  handleRequest :: JHttpExchange %1-> LServer ()
  handleRequest _httpExchange = Linear.do
      Ur root <- liftU $ asks envRootDirectory
      (httpExchange, httpExchange2) <- newLocalRef _httpExchange
      Ur tpath <-
        [java| $httpExchange2.getRequestURI().getPath() |] Linear.>>= reify_
      Ur (Response code msg) <-
        liftU $ listContents root (Text.unpack tpath)
      jmsg <- reflect msg
      [java| {
         $httpExchange.sendResponseHeaders($code, $jmsg.getBytes().length);
         $httpExchange.getResponseBody().write($jmsg.getBytes());
         $httpExchange.getResponseBody().close();
        } |]
  
  -- | @listContents root path@ lists the contents of the directory
  -- as @path@. The @path@ must be a descendent of @root@ or an error
  -- response is produced.
  listContents
    :: forall m.
       (MonadLogger m, MonadFileSystem m) => FilePath -> FilePath -> m Response
  listContents root rawPath = do
      mpath <- makePath root rawPath
      logInfoN $ Text.pack $ "Request received: " ++ show mpath
      case mpath of
        Just path -> do
          exists <- doesDirectoryExist path
          case exists of
            True -> do
              xs <- listDirectory path
              return (Response 200 $ Text.pack $ unlines xs)
            False ->
              return (Response 404 $ Text.pack
                "404: Path does not exist or it is not a directory."
              )
        Nothing ->
          return (Response 403 $ Text.pack "403: Illegal path.")
    where
      makePath :: String -> String -> m (Maybe String)
      makePath rootDir reqPath = do
        path <- canonicalizePath (rootDir </> makeRelative "/" reqPath)
        return $ do
          guard (root `isPrefixOf` path)
          return path
  
  -- | @withSignalHandlers cleanup io@ runs @io@ after installing signal
  -- handlers for SIGTERM and SIGINT. It ensures that @cleanup@ is run
  -- either when @io@ terminates or when SIGTERM or SIGINT are caught.
  withSignalHandlers
    :: IO () -> IO () -> IO ()
  withSignalHandlers cleanup io = do
      cleanupRef <- newIORef cleanup
      Catch.bracket
        ((,) <$> installHandler sigTERM (handler cleanupRef sigTERM) Nothing
             <*> installHandler sigINT (handler cleanupRef sigINT) Nothing
        )
        (\(hTERM, hINT) -> do
          _ <- installHandler sigTERM hTERM Nothing
          _ <- installHandler sigINT hINT Nothing
          runCleanup cleanupRef
        )
        (const io)
    where
      handler :: IORef (IO ()) -> Signal -> Handler
      handler cleanupRef _ = Catch (runCleanup cleanupRef)
  
      runCleanup cleanupRef =
        join $ atomicModifyIORef cleanupRef $ \maybeCleanup ->
          (return (), maybeCleanup)
  