{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Airship.Resource.Static
    ( FileInfo(..)
    , StaticOptions(..)
    , staticResource
    , allFilesAtRoot
    , epochToUTCTime
    , directoryTree
    ) where

#if __GLASGOW_HASKELL__ < 710
import           Control.Applicative ((<$>))
#endif

import           Airship.Headers (addResponseHeader)
import           Airship.Types ( ETag(Strong)
                               , ResponseBody(ResponseFile)
                               , Webmachine
                               , dispatchPath
                               , halt
                               )
import           Airship.Resource (Resource(..), defaultResource)


import           Control.Monad (foldM, when)
import qualified Crypto.Hash.MD5 as MD5
import           Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64.URL as Base64URL
import           Data.ByteString.Char8 (pack, split)
import           Data.Monoid ((<>))
import qualified Data.Text as T
import           Data.Text.Encoding (encodeUtf8)
import           Data.Time.Clock (UTCTime)
import           Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified Data.Trie as Trie
import           Network.HTTP.Media ((//))
import qualified Network.HTTP.Types as HTTP
import qualified Network.Mime as Mime
import qualified System.Directory as D
import           System.FilePath (takeFileName)
import qualified System.Posix.Files as Files
import           System.IO (IOMode(ReadMode), withBinaryFile)
import           System.Posix.Types (EpochTime)


data FileTree = FileTree { FileTree -> Trie FileInfo
tree :: Trie.Trie FileInfo
                         , FileTree -> Text
root :: T.Text
                         }

data FileInfo = FileInfo
    { FileInfo -> FilePath
_path          :: FilePath
    , FileInfo -> Integer
_size          :: Integer
    , FileInfo -> UTCTime
_lastModified  :: UTCTime
    , FileInfo -> ETag
_etag          :: ETag
    } deriving (Int -> FileInfo -> ShowS
[FileInfo] -> ShowS
FileInfo -> FilePath
(Int -> FileInfo -> ShowS)
-> (FileInfo -> FilePath) -> ([FileInfo] -> ShowS) -> Show FileInfo
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [FileInfo] -> ShowS
$cshowList :: [FileInfo] -> ShowS
show :: FileInfo -> FilePath
$cshow :: FileInfo -> FilePath
showsPrec :: Int -> FileInfo -> ShowS
$cshowsPrec :: Int -> FileInfo -> ShowS
Show, FileInfo -> FileInfo -> Bool
(FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool) -> Eq FileInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileInfo -> FileInfo -> Bool
$c/= :: FileInfo -> FileInfo -> Bool
== :: FileInfo -> FileInfo -> Bool
$c== :: FileInfo -> FileInfo -> Bool
Eq, Eq FileInfo
Eq FileInfo
-> (FileInfo -> FileInfo -> Ordering)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> Bool)
-> (FileInfo -> FileInfo -> FileInfo)
-> (FileInfo -> FileInfo -> FileInfo)
-> Ord FileInfo
FileInfo -> FileInfo -> Bool
FileInfo -> FileInfo -> Ordering
FileInfo -> FileInfo -> FileInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileInfo -> FileInfo -> FileInfo
$cmin :: FileInfo -> FileInfo -> FileInfo
max :: FileInfo -> FileInfo -> FileInfo
$cmax :: FileInfo -> FileInfo -> FileInfo
>= :: FileInfo -> FileInfo -> Bool
$c>= :: FileInfo -> FileInfo -> Bool
> :: FileInfo -> FileInfo -> Bool
$c> :: FileInfo -> FileInfo -> Bool
<= :: FileInfo -> FileInfo -> Bool
$c<= :: FileInfo -> FileInfo -> Bool
< :: FileInfo -> FileInfo -> Bool
$c< :: FileInfo -> FileInfo -> Bool
compare :: FileInfo -> FileInfo -> Ordering
$ccompare :: FileInfo -> FileInfo -> Ordering
$cp1Ord :: Eq FileInfo
Ord)

data StaticOptions = Cache | NoCache deriving (StaticOptions -> StaticOptions -> Bool
(StaticOptions -> StaticOptions -> Bool)
-> (StaticOptions -> StaticOptions -> Bool) -> Eq StaticOptions
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StaticOptions -> StaticOptions -> Bool
$c/= :: StaticOptions -> StaticOptions -> Bool
== :: StaticOptions -> StaticOptions -> Bool
$c== :: StaticOptions -> StaticOptions -> Bool
Eq)

epochToUTCTime :: EpochTime -> UTCTime
epochToUTCTime :: EpochTime -> UTCTime
epochToUTCTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (EpochTime -> POSIXTime) -> EpochTime -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochTime -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac

fileETag :: FilePath -> IO ETag
fileETag :: FilePath -> IO ETag
fileETag FilePath
p = FilePath -> IOMode -> (Handle -> IO ETag) -> IO ETag
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile FilePath
p IOMode
ReadMode Handle -> IO ETag
makeEtag
    where makeEtag :: Handle -> IO ETag
makeEtag Handle
h = do
            let ctx :: Ctx
ctx = Ctx
MD5.init
            Ctx
res <- Ctx -> Handle -> IO Ctx
go Ctx
ctx Handle
h
            ETag -> IO ETag
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ETag
Strong (Int -> ByteString -> ByteString
BS.take Int
22 (ByteString -> ByteString
Base64URL.encode (Ctx -> ByteString
MD5.finalize Ctx
res))))
          go :: Ctx -> Handle -> IO Ctx
go Ctx
ctx Handle
h = do
                ByteString
bs <- Handle -> Int -> IO ByteString
BS.hGetSome Handle
h Int
1024
                if ByteString -> Bool
BS.null ByteString
bs
                    then Ctx -> IO Ctx
forall (m :: * -> *) a. Monad m => a -> m a
return Ctx
ctx
                    else Ctx -> IO Ctx
forall (m :: * -> *) a. Monad m => a -> m a
return (Ctx -> ByteString -> Ctx
MD5.update Ctx
ctx ByteString
bs)


filteredDirectory :: FilePath -> IO [FilePath]
filteredDirectory :: FilePath -> IO [FilePath]
filteredDirectory FilePath
p = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
".", FilePath
".."])) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
D.getDirectoryContents FilePath
p

allFilesAtRoot :: FilePath -> IO [FilePath]
allFilesAtRoot :: FilePath -> IO [FilePath]
allFilesAtRoot FilePath
p = FilePath -> IO [FilePath]
filteredDirectory FilePath
p IO [FilePath] -> ([FilePath] -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([FilePath] -> FilePath -> IO [FilePath])
-> [FilePath] -> [FilePath] -> IO [FilePath]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [FilePath] -> FilePath -> IO [FilePath]
folder []
    where folder :: [FilePath] -> FilePath -> IO [FilePath]
          folder :: [FilePath] -> FilePath -> IO [FilePath]
folder [FilePath]
acc FilePath
f = do
            let fullPath :: FilePath
fullPath = FilePath
p FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
f
            Bool
exists <- FilePath -> IO Bool
D.doesDirectoryExist FilePath
fullPath
            if Bool
exists
                then do
                    [FilePath]
more <- FilePath -> IO [FilePath]
allFilesAtRoot (FilePath
p FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
f)
                    [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
more [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
acc)
                else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
fullPath FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
acc)

regularFileStatus :: [FilePath] -> IO [(FilePath, Files.FileStatus)]
regularFileStatus :: [FilePath] -> IO [(FilePath, FileStatus)]
regularFileStatus [FilePath]
fs = ((FilePath, FileStatus) -> Bool)
-> [(FilePath, FileStatus)] -> [(FilePath, FileStatus)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FileStatus -> Bool
Files.isRegularFile (FileStatus -> Bool)
-> ((FilePath, FileStatus) -> FileStatus)
-> (FilePath, FileStatus)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FileStatus) -> FileStatus
forall a b. (a, b) -> b
snd) ([(FilePath, FileStatus)] -> [(FilePath, FileStatus)])
-> IO [(FilePath, FileStatus)] -> IO [(FilePath, FileStatus)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                        (FilePath -> IO (FilePath, FileStatus))
-> [FilePath] -> IO [(FilePath, FileStatus)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
f -> (,) FilePath
f (FileStatus -> (FilePath, FileStatus))
-> IO FileStatus -> IO (FilePath, FileStatus)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
Files.getFileStatus FilePath
f) [FilePath]
fs

fileInfos :: [(FilePath, Files.FileStatus, ETag)] -> [(ByteString, FileInfo)]
fileInfos :: [(FilePath, FileStatus, ETag)] -> [(ByteString, FileInfo)]
fileInfos = ((FilePath, FileStatus, ETag) -> (ByteString, FileInfo))
-> [(FilePath, FileStatus, ETag)] -> [(ByteString, FileInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
p, FileStatus
s, ETag
e) -> (FilePath -> ByteString
pack FilePath
p, FilePath -> FileStatus -> ETag -> FileInfo
statusToInfo FilePath
p FileStatus
s ETag
e))

statusToInfo :: FilePath -> Files.FileStatus -> ETag -> FileInfo
statusToInfo :: FilePath -> FileStatus -> ETag -> FileInfo
statusToInfo FilePath
p FileStatus
i ETag
e = FileInfo :: FilePath -> Integer -> UTCTime -> ETag -> FileInfo
FileInfo { _path :: FilePath
_path = FilePath
p
                              , _size :: Integer
_size = FileOffset -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileStatus -> FileOffset
Files.fileSize FileStatus
i)
                              , _lastModified :: UTCTime
_lastModified = EpochTime -> UTCTime
epochToUTCTime (FileStatus -> EpochTime
Files.modificationTime FileStatus
i)
                              , _etag :: ETag
_etag = ETag
e
                              }

directoryTree :: FilePath -> IO FileTree
directoryTree :: FilePath -> IO FileTree
directoryTree FilePath
f = do
    [(FilePath, FileStatus)]
regularFiles <- FilePath -> IO [FilePath]
allFilesAtRoot FilePath
f IO [FilePath]
-> ([FilePath] -> IO [(FilePath, FileStatus)])
-> IO [(FilePath, FileStatus)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [FilePath] -> IO [(FilePath, FileStatus)]
regularFileStatus
    [ETag]
etags <- ((FilePath, FileStatus) -> IO ETag)
-> [(FilePath, FileStatus)] -> IO [ETag]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FilePath -> IO ETag
fileETag (FilePath -> IO ETag)
-> ((FilePath, FileStatus) -> FilePath)
-> (FilePath, FileStatus)
-> IO ETag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FileStatus) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FileStatus)]
regularFiles
    let infos :: [(ByteString, FileInfo)]
infos = [(FilePath, FileStatus, ETag)] -> [(ByteString, FileInfo)]
fileInfos (((FilePath, FileStatus) -> ETag -> (FilePath, FileStatus, ETag))
-> [(FilePath, FileStatus)]
-> [ETag]
-> [(FilePath, FileStatus, ETag)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(FilePath
a,FileStatus
b) ETag
c -> (FilePath
a,FileStatus
b,ETag
c)) [(FilePath, FileStatus)]
regularFiles [ETag]
etags)
    FileTree -> IO FileTree
forall (m :: * -> *) a. Monad m => a -> m a
return (Trie FileInfo -> Text -> FileTree
FileTree ([(ByteString, FileInfo)] -> Trie FileInfo
forall a. [(ByteString, a)] -> Trie a
Trie.fromList [(ByteString, FileInfo)]
infos) (FilePath -> Text
T.pack FilePath
f))

staticResource :: Monad m => StaticOptions -> FilePath -> IO (Resource m)
staticResource :: StaticOptions -> FilePath -> IO (Resource m)
staticResource StaticOptions
options FilePath
p = StaticOptions -> FileTree -> Resource m
forall (m :: * -> *).
Monad m =>
StaticOptions -> FileTree -> Resource m
staticResource' StaticOptions
options (FileTree -> Resource m) -> IO FileTree -> IO (Resource m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileTree
directoryTree FilePath
p

staticResource' :: Monad m => StaticOptions -> FileTree -> Resource m
staticResource' :: StaticOptions -> FileTree -> Resource m
staticResource' StaticOptions
options FileTree{Text
Trie FileInfo
root :: Text
tree :: Trie FileInfo
root :: FileTree -> Text
tree :: FileTree -> Trie FileInfo
..} = Resource m
forall (m :: * -> *). Monad m => Resource m
defaultResource
    { allowedMethods :: Webmachine m [ByteString]
allowedMethods = [ByteString] -> Webmachine m [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ ByteString
HTTP.methodGet, ByteString
HTTP.methodHead ]
    , resourceExists :: Webmachine m Bool
resourceExists = Webmachine m FileInfo
forall (m :: * -> *). Monad m => Webmachine m FileInfo
getFileInfo Webmachine m FileInfo -> Webmachine m Bool -> Webmachine m Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Webmachine m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    , generateETag :: Webmachine m (Maybe ETag)
generateETag = if StaticOptions
options StaticOptions -> StaticOptions -> Bool
forall a. Eq a => a -> a -> Bool
== StaticOptions
Cache
                        then ETag -> Maybe ETag
forall a. a -> Maybe a
Just (ETag -> Maybe ETag)
-> (FileInfo -> ETag) -> FileInfo -> Maybe ETag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> ETag
_etag (FileInfo -> Maybe ETag)
-> Webmachine m FileInfo -> Webmachine m (Maybe ETag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Webmachine m FileInfo
forall (m :: * -> *). Monad m => Webmachine m FileInfo
getFileInfo
                        else Maybe ETag -> Webmachine m (Maybe ETag)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ETag
forall a. Maybe a
Nothing
    , lastModified :: Webmachine m (Maybe UTCTime)
lastModified = if StaticOptions
options StaticOptions -> StaticOptions -> Bool
forall a. Eq a => a -> a -> Bool
== StaticOptions
Cache
                        then UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime)
-> (FileInfo -> UTCTime) -> FileInfo -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo -> UTCTime
_lastModified (FileInfo -> Maybe UTCTime)
-> Webmachine m FileInfo -> Webmachine m (Maybe UTCTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Webmachine m FileInfo
forall (m :: * -> *). Monad m => Webmachine m FileInfo
getFileInfo
                        else Maybe UTCTime -> Webmachine m (Maybe UTCTime)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UTCTime
forall a. Maybe a
Nothing
    , contentTypesProvided :: Webmachine m [(MediaType, Webmachine m ResponseBody)]
contentTypesProvided = do
        FileInfo
fInfo <- Webmachine m FileInfo
forall (m :: * -> *). Monad m => Webmachine m FileInfo
getFileInfo
        Bool -> Webmachine m () -> Webmachine m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StaticOptions
options StaticOptions -> StaticOptions -> Bool
forall a. Eq a => a -> a -> Bool
== StaticOptions
NoCache) Webmachine m ()
forall (m :: * -> *). Monad m => Webmachine m ()
addNoCacheHeaders
        let response :: Webmachine m ResponseBody
response = ResponseBody -> Webmachine m ResponseBody
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe FilePart -> ResponseBody
ResponseFile (FileInfo -> FilePath
_path FileInfo
fInfo) Maybe FilePart
forall a. Maybe a
Nothing)
            fileName :: Text
fileName = FilePath -> Text
T.pack (ShowS
takeFileName (FileInfo -> FilePath
_path FileInfo
fInfo))
            fromExtension :: ByteString
fromExtension = Text -> ByteString
Mime.defaultMimeLookup Text
fileName
            (ByteString
a:ByteString
b:[ByteString]
_tl) = Char -> ByteString -> [ByteString]
split Char
'/' ByteString
fromExtension
            mediaType :: MediaType
mediaType = ByteString
a ByteString -> ByteString -> MediaType
// ByteString
b
        [(MediaType, Webmachine m ResponseBody)]
-> Webmachine m [(MediaType, Webmachine m ResponseBody)]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (MediaType
mediaType, Webmachine m ResponseBody
response)
               , (MediaType
"application/octet-stream", Webmachine m ResponseBody
response)]
    }
    where getFileInfo :: Monad m => Webmachine m FileInfo
          getFileInfo :: Webmachine m FileInfo
getFileInfo = do
            [Text]
dispath <- Webmachine m [Text]
forall (m :: * -> *). Monad m => Webmachine m [Text]
dispatchPath
            let key :: ByteString
key = Text -> ByteString
encodeUtf8 (Text -> [Text] -> Text
T.intercalate Text
"/" (Text
rootText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
dispath))
            let res :: Maybe FileInfo
res = ByteString -> Trie FileInfo -> Maybe FileInfo
forall a. ByteString -> Trie a -> Maybe a
Trie.lookup ByteString
key Trie FileInfo
tree
            case Maybe FileInfo
res of
                (Just FileInfo
r) -> FileInfo -> Webmachine m FileInfo
forall (m :: * -> *) a. Monad m => a -> m a
return FileInfo
r
                Maybe FileInfo
Nothing -> Status -> Webmachine m FileInfo
forall (m :: * -> *) a. Monad m => Status -> Webmachine m a
halt Status
HTTP.status404

addNoCacheHeaders :: Monad m => Webmachine m ()
addNoCacheHeaders :: Webmachine m ()
addNoCacheHeaders = do
    Header -> Webmachine m ()
forall (m :: * -> *). Monad m => Header -> Webmachine m ()
addResponseHeader (HeaderName
HTTP.hCacheControl, ByteString
"no-cache, no-store, must-revalidate")
    Header -> Webmachine m ()
forall (m :: * -> *). Monad m => Header -> Webmachine m ()
addResponseHeader (HeaderName
"Pragma", ByteString
"no-cache")
    Header -> Webmachine m ()
forall (m :: * -> *). Monad m => Header -> Webmachine m ()
addResponseHeader (HeaderName
"Expires", ByteString
"0")