]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/StaticFile.hs
docs
[Lucu.git] / Network / HTTP / Lucu / StaticFile.hs
1 {-# LANGUAGE
2     DoAndIfThenElse
3   , OverloadedStrings
4   , QuasiQuotes
5   , UnicodeSyntax
6   #-}
7 -- | Handling static files on the filesystem.
8 module Network.HTTP.Lucu.StaticFile
9     ( staticFile
10     , staticDir
11     )
12     where
13 import Control.Monad
14 import Control.Monad.Unicode
15 import Control.Monad.Trans
16 import Data.ByteString (ByteString)
17 import qualified Data.ByteString.Lazy.Char8 as LBS
18 import Data.Monoid.Unicode
19 import Data.String
20 import qualified Data.Text as T
21 import qualified Data.Text.Encoding as T
22 import Network.HTTP.Lucu.Abortion
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.MIMEType hiding (mimeType)
25 import Network.HTTP.Lucu.MIMEType.Guess
26 import Network.HTTP.Lucu.MIMEType.TH
27 import Network.HTTP.Lucu.Resource
28 import Network.HTTP.Lucu.Resource.Internal
29 import Network.HTTP.Lucu.Response
30 import Network.HTTP.Lucu.Utils
31 import Prelude.Unicode
32 import System.Directory
33 import System.FilePath
34
35 -- | @'staticFile' fpath@ is a 'Resource' which serves the file at
36 -- @fpath@ on the filesystem.
37 staticFile ∷ FilePath → Resource
38 staticFile path
39     = (∅) {
40         resGet  = Just $ handleStaticFile True  path
41       , resHead = Just $ handleStaticFile False path
42       }
43
44 octetStream ∷ MIMEType
45 octetStream = [mimeType| application/octet-stream |]
46
47 handleStaticFile ∷ Bool → FilePath → Rsrc ()
48 handleStaticFile sendContent path
49     = do isDir ← liftIO $ doesDirectoryExist path
50          when isDir
51              $ abort
52              $ mkAbortion Forbidden [] Nothing
53
54          isFile ← liftIO $ doesFileExist path
55          unless isFile
56              foundNoEntity'
57
58          perms ← liftIO $ getPermissions path
59          unless (readable perms)
60              $ abort
61              $ mkAbortion Forbidden [] Nothing
62
63          lastMod ← liftIO $ getLastModified path
64          foundTimeStamp lastMod
65
66          conf ← getConfig
67          case guessTypeByFileName (cnfExtToMIMEType conf) path of
68            Nothing   → setContentType octetStream
69            Just mime → setContentType mime
70
71          when sendContent
72              $ liftIO (LBS.readFile path) ≫= putChunks
73
74 -- | @'staticDir' dir@ is a 'Resource' which maps all files in @dir@
75 -- and its subdirectories on the filesystem to the resource tree. Thus
76 -- having 'Network.HTTP.Lucu.nonGreedy' 'staticDir' in a tree makes no
77 -- sense.
78 --
79 -- Note that 'staticDir' currently doesn't have a directory-listing
80 -- capability. Requesting the content of a directory will end up being
81 -- replied with /403 Forbidden/.
82 staticDir ∷ FilePath → Resource
83 staticDir path
84     = (∅) {
85         resGet  = Just $ handleStaticDir True  path
86       , resHead = Just $ handleStaticDir False path
87       }
88
89 -- TODO: implement directory listing.
90 handleStaticDir ∷ Bool → FilePath → Rsrc ()
91 handleStaticDir sendContent basePath
92     = do extraPath ← getPathInfo
93          securityCheck extraPath
94          let path = basePath </> joinPath (map dec8 extraPath)
95          handleStaticFile sendContent path
96     where
97       dec8 ∷ ByteString → String
98       dec8 = T.unpack ∘ T.decodeUtf8
99
100 securityCheck ∷ (Eq s, Show s, IsString s, Monad m) ⇒ [s] → m ()
101 securityCheck pathElems
102     = when (any (≡ "..") pathElems)
103           $ fail ("security error: " ⧺ show pathElems)