From dce5159d2a7c8d2043a9686cbeca76fec69fac87 Mon Sep 17 00:00:00 2001
From: Daniel Schadt <kingdread@gmx.de>
Date: Tue, 29 Jun 2021 00:08:09 +0200
Subject: Add static file server

Some simple code that allows Cana to serve files from a directory, and
not just provide static responses.
---
 src/Cana/Extra.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 src/Cana/Extra.hs

(limited to 'src')

diff --git a/src/Cana/Extra.hs b/src/Cana/Extra.hs
new file mode 100644
index 0000000..c776160
--- /dev/null
+++ b/src/Cana/Extra.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE OverloadedStrings #-}
+-- |
+-- Module     : Cana.Extra
+--
+-- This module contains some extra goodies for writing a Gemini server with
+-- "Cana", for exmaple a static file server.
+
+module Cana.Extra
+    ( -- * High-Level handlers
+      staticFiles
+    ) where
+
+import           Cana.Types
+import           Cana.Protocol
+
+import           Control.Applicative
+import           Control.Monad
+import           Control.Monad.Trans.Maybe
+
+import           Data.String
+import           Data.Maybe
+import qualified Data.Text                  as T
+import           System.FilePath
+import           System.Directory
+import           Control.Monad.IO.Class
+import qualified Data.ByteString.Lazy       as BSL
+import           Data.ByteString.Lazy.Char8 (pack)
+import           Network.URI
+import           Network.Mime
+
+
+-- | Default name for the directory index file.
+defaultIndexFile :: String
+defaultIndexFile = "index.gmi"
+
+-- | The Gemini MIME type.
+geminiMime :: IsString a => a
+geminiMime = "text/gemini"
+
+-- | A static file handler.
+--
+-- This handler takes a file path and looks up any request in the given
+-- directory.
+staticFiles :: FilePath -- ^ Base directory where static files are searched.
+            -> Handler
+staticFiles basedir request = do
+  let reqPath = sanitize . uriPath . requestUri $ request
+      fsPath  = basedir ++ reqPath
+      notFoundResponse = GeminiResponse
+        { responseStatus = codeNotFound
+        , responseMeta   = "Those are not the capsules you are looking for"
+        , responseData   = ""
+        }
+
+  dirIndex <- liftIO $ readDirIndex fsPath
+  fileContent <- liftIO $ readFileContent fsPath
+  return $ fromMaybe notFoundResponse (dirIndex <|> fileContent)
+  where
+    sanitize :: FilePath -> FilePath
+    sanitize = joinPath
+      . filter (\p -> dropTrailingPathSeparator p /= "..")
+      . splitPath
+      . normalise
+
+    readDirIndex :: FilePath -> IO (Maybe GeminiResponse)
+    readDirIndex path = runMaybeT $ do
+      guard $ hasTrailingPathSeparator path
+      liftIO (doesDirectoryExist path) >>= guard
+      liftIO (doesFileExist $ path </> defaultIndexFile) >>= guard
+      content <- liftIO $ BSL.readFile (path </> defaultIndexFile)
+      return GeminiResponse
+        { responseStatus = codeSuccess
+        , responseMeta   = geminiMime
+        , responseData   = content
+        }
+
+    readFileContent :: FilePath -> IO (Maybe GeminiResponse)
+    readFileContent path = runMaybeT $ do
+      liftIO (doesFileExist path) >>= guard
+      content <- liftIO $ BSL.readFile path
+      return GeminiResponse
+        { responseStatus = codeSuccess
+        , responseMeta   = getMime path
+        , responseData   = content
+        }
+
+    getMime :: FilePath -> BSL.ByteString
+    getMime path
+      | takeExtension path == ".gmi" = geminiMime
+      | otherwise                    = BSL.fromStrict
+        . defaultMimeLookup . T.pack $ takeFileName path
-- 
cgit v1.2.3