spacecookie-1.1.0.0: server/Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
import Network.Spacecookie.Config
import Network.Spacecookie.FileType
import Network.Spacecookie.Path
import Network.Spacecookie.Systemd

import Paths_spacecookie (version)

import Network.Gopher
import Network.Gopher.Util.Gophermap
import qualified Data.ByteString as B
import Data.ByteString.Short (fromShort)
import Control.Exception (catches, Handler (..))
import Control.Monad (when, unless)
import Data.Aeson (eitherDecodeStrict')
import Data.Attoparsec.ByteString (parseOnly)
import Data.Bifunctor (first)
import Data.ByteString.Builder (Builder ())
import Data.Either (rights)
import Data.Maybe (fromMaybe)
import Data.Version (showVersion)
import System.Console.GetOpt
import System.Directory.OsPath (doesFileExist, listDirectory)
import System.Environment
import System.Exit
import qualified System.File.OsPath as F
import qualified System.OsPath as OP
import System.OsPath.Posix ( PosixPath, takeFileName, (</>)
                           , dropDrive, normalise)
import qualified System.OsString.Posix as Posix
import System.OsString.Internal.Types (PosixString (..), OsString (..))
import qualified System.Log.FastLogger as FL
import System.Posix.Directory (changeWorkingDirectory)
import System.Socket (SocketException ())
import System.Posix.User

data Flags = Version | Usage

options :: [OptDescr Flags]
options =
  [ Option "h" [ "help", "usage" ] (NoArg Usage)   "Print usage information"
  , Option []  [ "version" ]       (NoArg Version) "Show used version of spacecookie"
  ]

main :: IO ()
main = do
  args <- getArgs
  case getOpt Permute options args of
    ([], [configFile], []) -> runServer =<< OP.encodeUtf configFile
    -- this works because we only have two flags atm
    ([Version], _, []) -> putStrLn $ showVersion version
    (_, _, []) -> printUsage
    (_, _, es) -> die . mconcat $
      "errors occurred while parsing options:\n":es

runServer :: OP.OsPath -> IO ()
runServer configFile = do
  doesFileExist configFile >>=
    (flip unless) (die "could not open config file")
  config' <- eitherDecodeStrict' <$> F.readFile' configFile
  case config' of
    Left err -> die $ "failed to parse config: " ++ err
    Right config -> do
      changeWorkingDirectory (rootDirectory config)
      (logHandler, logStopAction) <- fromMaybe (Nothing, pure ())
        . fmap (first Just) <$> makeLogHandler (logConfig config)
      let cfg = GopherConfig
            { cServerName = serverName config
            , cListenAddr = listenAddr config
            , cServerPort = serverPort config
            , cLogHandler = logHandler
            }
          logIO = fromMaybe noLog logHandler

      let setupFailureHandler e = do
            logIO GopherLogLevelError
              $  "Exception occurred in setup step: "
              <> toGopherLogStr (show e)
            logStopAction
            exitFailure
          catchSetupFailure a = a `catches`
            [ Handler (setupFailureHandler :: SystemdException -> IO ())
            , Handler (setupFailureHandler :: SocketException -> IO ())
            ]

      catchSetupFailure $ runGopherManual
        (systemdSocket cfg)
        (afterSocketSetup logIO config)
        (\s -> do
          _ <- notifyStopping
          logStopAction
          systemdStoreOrClose s)
        cfg
        (spacecookie logIO)

-- | If 'runUserName' is configured, call 'setGroupID' and 'setUserID'
--   to switch to the given user and their primary group.
--   Requires special privileges (usually  root). Will raise an exception if
--   either the user does not exist or the current user has no  permission to
--   change UID/GID.
--
--   After that, notify systemd that we are ready if applicable.
afterSocketSetup :: GopherLogHandler -> Config -> IO ()
afterSocketSetup logIO cfg = do
  case runUserName cfg of
    Nothing -> pure ()
    Just username  -> do
      user <- getUserEntryForName username
      setGroupID $ userGroupID user
      setUserID $ userID user
      logIO GopherLogLevelInfo $ "Changed to user " <> toGopherLogStr username
  _ <- notifyReady
  pure ()

printUsage :: IO ()
printUsage = do
  n <- getProgName
  putStrLn . flip usageInfo options $
    mconcat [ "Usage: ", n, " CONFIG\n" ]

makeLogHandler :: LogConfig -> IO (Maybe (GopherLogHandler, IO ()))
makeLogHandler lc
  | not (logEnable lc) = pure Nothing
  | otherwise =
  let wrapTimedLogger :: FL.TimedFastLogger -> FL.FastLogger
      wrapTimedLogger logger str = logger $ (\t ->
        "[" <> FL.toLogStr t <> "]" <> str)
      formatLevel lvl =
        case lvl of
          GopherLogLevelInfo  -> "[info] "
          GopherLogLevelWarn  -> "[warn] "
          GopherLogLevelError -> "[err ] "
      processMsg =
        if logHideIps lc
          then hideSensitive
          else id
      logHandler :: FL.FastLogger -> GopherLogLevel -> GopherLogStr -> IO ()
      logHandler logger lvl msg = when (lvl <= logLevel lc) . logger
        $  formatLevel lvl
        <> ((FL.toLogStr :: Builder -> FL.LogStr) . fromGopherLogStr . processMsg $ msg)
        <> "\n"
      logType = FL.LogStderr FL.defaultBufSize
   in do
     (logger, cleanup) <-
       if logHideTime lc
         then FL.newFastLogger logType
         else first wrapTimedLogger <$> do
           timeCache <- FL.newTimeCache FL.simpleTimeFormat
           FL.newTimedFastLogger timeCache logType
     pure $ Just (logHandler logger, cleanup)

noLog :: GopherLogHandler
noLog = const . const $ pure ()

spacecookie :: GopherLogHandler -> GopherRequest -> IO GopherResponse
spacecookie logger req = do
  let selector = requestSelector req
      path = normalise $ dropDrive $ sanitizePath (Posix.fromBytestring selector)
  pt <- gopherFileType path

  case pt of
    Left PathIsNotAllowed ->
      pure . ErrorResponse $ mconcat
        [ "Accessing '",  selector, "' is not allowed." ]
    Left PathDoesNotExist -> pure $
      if "URL:" `B.isPrefixOf` selector
        then ErrorResponse $ mconcat
          [ "spacecookie does not support proxying HTTP, "
          , "try using a gopher client that supports URL: selectors. "
          , "If you tried to request a resource called '"
          , selector, "', it does not exist." ]
        else ErrorResponse $ mconcat
          [ "The requested resource '", selector
          , "' does not exist or is not available." ]
    Right ft ->
      case ft of
        Error -> pure $ ErrorResponse $ "An unknown error occurred"
        -- always use gophermapResponse which falls back
        -- to directoryResponse if there is no gophermap file
        Directory -> gophermapResponse logger path
        _ -> fileResponse logger path

fileResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse
fileResponse _ path = FileResponse <$> F.readFile' (OsString path)

directoryResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse
directoryResponse _ path =
  let makeItem :: Either a GopherFileType -> PosixPath -> Either a GopherMenuItem
      makeItem t file = do
        fileType <- t
        pure $
          Item fileType (pathToBS $ takeFileName file) (pathToBS file) Nothing Nothing
   in do
     dir <- map ((path </>) . getOsString)
       <$> listDirectory (OsString path)
     fileTypes <- mapM gopherFileType dir

     pure . MenuResponse . rights
       $ zipWith makeItem fileTypes (map makeAbsolute dir)
  where
    pathToBS :: PosixPath -> B.ByteString
    pathToBS = fromShort . getPosixString

gophermapResponse :: GopherLogHandler -> PosixPath -> IO GopherResponse
gophermapResponse logger path = do
  let gophermap = path </> [Posix.pstr|.gophermap|]
  exists <- doesFileExist $ OsString gophermap
  parsed <-
    if exists
      then parseOnly parseGophermap <$> F.readFile' (OsString gophermap)
      else pure $ Left "Gophermap file does not exist"
  case parsed of
    Left err -> do
      when exists . logger GopherLogLevelWarn
        $  "Could not parse gophermap at " <> toGopherLogStr gophermap
        <> ": " <> toGopherLogStr err
      directoryResponse logger path
    Right right -> pure
      $ gophermapToDirectoryResponse (makeAbsolute path) right