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.
---
 Cana.cabal        | 13 ++++++++
 app/Main.hs       |  3 +-
 src/Cana/Extra.hs | 91 +++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 106 insertions(+), 1 deletion(-)
 create mode 100644 src/Cana/Extra.hs

diff --git a/Cana.cabal b/Cana.cabal
index cc3c863..42b224c 100644
--- a/Cana.cabal
+++ b/Cana.cabal
@@ -26,6 +26,7 @@ source-repository head
 library
   exposed-modules:
       Cana
+      Cana.Extra
       Cana.Monad
       Cana.Protocol
       Cana.Router
@@ -39,8 +40,12 @@ library
       base >=4.7 && <5
     , bytestring
     , data-default
+    , directory
+    , filepath
+    , mime-types
     , network
     , network-uri
+    , text
     , tls
     , transformers
     , x509
@@ -59,8 +64,12 @@ executable Cana-exe
     , base >=4.7 && <5
     , bytestring
     , data-default
+    , directory
+    , filepath
+    , mime-types
     , network
     , network-uri
+    , text
     , tls
     , transformers
     , x509
@@ -80,8 +89,12 @@ test-suite Cana-test
     , base >=4.7 && <5
     , bytestring
     , data-default
+    , directory
+    , filepath
+    , mime-types
     , network
     , network-uri
+    , text
     , tls
     , transformers
     , x509
diff --git a/app/Main.hs b/app/Main.hs
index 000726d..50ca151 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -4,6 +4,7 @@ module Main where
 import Cana
 import Cana.Protocol
 import Cana.Router
+import Cana.Extra
 
 defaultResponse :: GeminiResponse
 defaultResponse = GeminiResponse
@@ -14,5 +15,5 @@ defaultResponse = GeminiResponse
 
 main :: IO ()
 main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key"
-  [ (anyRoute, const $ return defaultResponse)
+  [ (anyRoute, staticFiles "gmdocs")
   ]
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