diff options
| -rw-r--r-- | src/Cana/Handlers.hs | 67 | ||||
| -rw-r--r-- | src/Cana/Util.hs | 6 |
2 files changed, 70 insertions, 3 deletions
diff --git a/src/Cana/Handlers.hs b/src/Cana/Handlers.hs index 512ebf3..acf4e7c 100644 --- a/src/Cana/Handlers.hs +++ b/src/Cana/Handlers.hs @@ -8,20 +8,26 @@ module Cana.Handlers ( -- * High-Level handlers staticFiles + , staticFiles' , runCGI + -- * Auxiliary objects + , StaticFiles(..) ) where import Cana.Types import Cana.Protocol import Cana.Monad +import Cana.Util import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe import Control.Exception (SomeException, try) +import Data.Default import Data.String import Data.Maybe +import Data.List import qualified Data.Text as T import System.FilePath import System.Directory @@ -43,14 +49,44 @@ defaultIndexFile = "index.gmi" geminiMime :: IsString a => a geminiMime = "text/gemini" + +-- | Settings for the static file handler. +-- +-- Usually to be used with the 'Default' instance and selectively overriden +-- fields. +data StaticFiles = StaticFiles + { sfBasePath :: FilePath -- ^ The base path of the served directory. + , sfDoIndices :: Bool -- ^ Whether a directory without explicit index file + -- should have its contents listed. + } deriving (Eq, Show) + +instance Default StaticFiles where + def = StaticFiles + { sfBasePath = "." + , sfDoIndices = False + } + + -- | A static file handler. -- -- This handler takes a file path and looks up any request in the given -- directory. +-- +-- This is a convenience wrapper around 'staticFiles'', which offers more +-- configuration. staticFiles :: FilePath -- ^ Base directory where static files are searched. -> Handler -staticFiles basedir request = do - let reqPath' = uriPath . requestUri $ request +staticFiles basepath = staticFiles' $ def { sfBasePath = basepath } + + +-- | A static file handler. +-- +-- This is a more advanced version of 'staticFiles' that allows for +-- finer-grained configuration. +staticFiles' :: StaticFiles -> Handler +staticFiles' settings request = do + let basedir = sfBasePath settings + reqPath' = uriPath . requestUri $ request reqPath = if null reqPath' then "/" else sanitize reqPath' fsPath = basedir ++ reqPath notFoundResponse = GeminiResponse @@ -60,8 +96,11 @@ staticFiles basedir request = do } dirIndex <- liftIO $ readDirIndex fsPath + dirList <- if sfDoIndices settings + then liftIO $ listDirFiles fsPath + else return Nothing fileContent <- liftIO $ readFileContent fsPath - return $ fromMaybe notFoundResponse (dirIndex <|> fileContent) + return $ fromMaybe notFoundResponse (dirIndex <|> dirList <|> fileContent) where sanitize :: FilePath -> FilePath sanitize = joinPath @@ -81,6 +120,21 @@ staticFiles basedir request = do , responseData = content } + listDirFiles :: FilePath -> IO (Maybe GeminiResponse) + listDirFiles path = runMaybeT $ do + guard $ hasTrailingPathSeparator path + liftIO (doesDirectoryExist path) >>= guard + files <- liftIO $ listDirectory path + -- Make sure directories have a trailing slash when linked. + files <- forM files $ \f -> do + isDir <- liftIO $ doesDirectoryExist (path </> f) + return $ applyWhen isDir (++ "/") f + return GeminiResponse + { responseStatus = codeSuccess + , responseMeta = geminiMime + , responseData = renderDirList files + } + readFileContent :: FilePath -> IO (Maybe GeminiResponse) readFileContent path = runMaybeT $ do liftIO (doesFileExist path) >>= guard @@ -97,6 +151,13 @@ staticFiles basedir request = do | otherwise = BSL.fromStrict . defaultMimeLookup . T.pack $ takeFileName path + renderDirList :: [FilePath] -> BSL.ByteString + renderDirList = ((header <> "\n") <>) . renderList + where + header = "# Directory Contents" + renderList = BSL.intercalate "\n" + . map (UTF8.fromString . ("=> " ++)) . sort + -- | Returns a handler that calls an external script for each request. runCGI :: FilePath -- ^ CGI script -> [String] -- ^ Script arguments diff --git a/src/Cana/Util.hs b/src/Cana/Util.hs index 1f0c798..fd61c31 100644 --- a/src/Cana/Util.hs +++ b/src/Cana/Util.hs @@ -7,6 +7,7 @@ module Cana.Util ( splitList , mapLeft , unwrapMaybe + , applyWhen ) where import Control.Monad.Trans.Except @@ -38,3 +39,8 @@ mapLeft _ (Right x) = Right x unwrapMaybe :: Monad m => b -> Maybe a -> ExceptT b m a unwrapMaybe err Nothing = throwE err unwrapMaybe _ (Just x) = return x + +-- | Apply the given function iff the condition is met. +applyWhen :: Bool -> (a -> a) -> a -> a +applyWhen True f = f +applyWhen _ _ = id |