From 699e7ddb239407704a2adee7b4fb8a6c0eb04c8b Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Mon, 19 Jul 2021 22:04:46 +0200
Subject: implement directory listings

This allows Cana to do directory listings. Since we expect more settings
to become available for the static file handler (such as ExecCGI or
IndexFile), a struct holding the parameters has been introduced already.
---
 src/Cana/Handlers.hs | 67 +++++++++++++++++++++++++++++++++++++++++++++++++---
 src/Cana/Util.hs     |  6 +++++
 2 files changed, 70 insertions(+), 3 deletions(-)

(limited to 'src')

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
-- 
cgit v1.2.3