+{-# LANGUAGE
+ DoAndIfThenElse
+ , OverloadedStrings
+ , QuasiQuotes
+ , UnicodeSyntax
+ #-}
+-- | Handling static files on the filesystem.
module Network.HTTP.Lucu.StaticFile
- (
+ ( staticFile
+ , staticDir
)
where
+import Control.Monad
+import Control.Monad.Unicode
+import Control.Monad.Trans
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Monoid.Unicode
+import Data.String
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.MIMEType.Guess
+import Network.HTTP.Lucu.MIMEType.TH
+import Network.HTTP.Lucu.Resource
+import Network.HTTP.Lucu.Resource.Internal
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+import System.Directory
+import System.FilePath
-
-staticFile :: FilePath -> ResourceDef
+-- | @'staticFile' fpath@ is a 'Resource' which serves the file at
+-- @fpath@ on the filesystem.
+staticFile ∷ FilePath → Resource
staticFile path
- = ResourceDef {
- resUsesNativeThread = False
- , resIsGreedy = False
- , resGet
- = Just $ do
\ No newline at end of file
+ = (∅) {
+ resGet = Just $ handleStaticFile True path
+ , resHead = Just $ handleStaticFile False path
+ }
+
+octetStream ∷ MIMEType
+octetStream = [mimeType| application/octet-stream |]
+
+handleStaticFile ∷ Bool → FilePath → Rsrc ()
+handleStaticFile sendContent path
+ = do isDir ← liftIO $ doesDirectoryExist path
+ when isDir
+ $ abort
+ $ mkAbortion Forbidden [] Nothing
+
+ isFile ← liftIO $ doesFileExist path
+ unless isFile
+ foundNoEntity'
+
+ perms ← liftIO $ getPermissions path
+ unless (readable perms)
+ $ abort
+ $ mkAbortion Forbidden [] Nothing
+
+ lastMod ← liftIO $ getLastModified path
+ foundTimeStamp lastMod
+
+ conf ← getConfig
+ case guessTypeByFileName (cnfExtToMIMEType conf) path of
+ Nothing → setContentType octetStream
+ Just mime → setContentType mime
+
+ when sendContent
+ $ liftIO (LBS.readFile path) ≫= putChunks
+
+-- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
+-- and its subdirectories on the filesystem to the resource tree. Thus
+-- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
+-- sense.
+--
+-- Note that 'staticDir' currently doesn't have a directory-listing
+-- capability. Requesting the content of a directory will end up being
+-- replied with /403 Forbidden/.
+staticDir ∷ FilePath → Resource
+staticDir path
+ = (∅) {
+ resGet = Just $ handleStaticDir True path
+ , resHead = Just $ handleStaticDir False path
+ }
+
+-- TODO: implement directory listing.
+handleStaticDir ∷ Bool → FilePath → Rsrc ()
+handleStaticDir sendContent basePath
+ = do extraPath ← getPathInfo
+ securityCheck extraPath
+ let path = basePath </> joinPath (map dec8 extraPath)
+ handleStaticFile sendContent path
+ where
+ dec8 ∷ ByteString → String
+ dec8 = T.unpack ∘ T.decodeUtf8
+
+securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
+securityCheck pathElems
+ = when (any (≡ "..") pathElems)
+ $ fail ("security error: " ⧺ show pathElems)