{-# LANGUAGE CPP #-}
-- | Lookup files stored in memory instead of from the filesystem.
module WaiAppStatic.Storage.Embedded.Runtime
    ( -- * Settings
      embeddedSettings
    ) where

import WaiAppStatic.Types
import Data.ByteString (ByteString)
import Control.Arrow ((&&&), second)
import Data.List
import Data.ByteString.Builder (byteString)
import qualified Network.Wai as W
import qualified Data.Map as Map
import Data.Function (on)
import qualified Data.Text as T
import Data.Ord
import qualified Data.ByteString as S
#ifdef MIN_VERSION_cryptonite
import Crypto.Hash (hash, MD5, Digest)
import Data.ByteArray.Encoding
#else
import Crypto.Hash.MD5 (hash)
import Data.ByteString.Base64 (encode)
#endif
import WaiAppStatic.Storage.Filesystem (defaultFileServerSettings)
import System.FilePath (isPathSeparator)

-- | Serve the list of path/content pairs directly from memory.
embeddedSettings :: [(Prelude.FilePath, ByteString)] -> StaticSettings
embeddedSettings :: [(FilePath, ByteString)] -> StaticSettings
embeddedSettings [(FilePath, ByteString)]
files = (FilePath -> StaticSettings
defaultFileServerSettings (FilePath -> StaticSettings) -> FilePath -> StaticSettings
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"unused")
    { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = Embedded -> Pieces -> IO LookupResult
embeddedLookup (Embedded -> Pieces -> IO LookupResult)
-> Embedded -> Pieces -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ [(FilePath, ByteString)] -> Embedded
toEmbedded [(FilePath, ByteString)]
files
    }

type Embedded = Map.Map Piece EmbeddedEntry

data EmbeddedEntry = EEFile ByteString | EEFolder Embedded

embeddedLookup :: Embedded -> Pieces -> IO LookupResult
embeddedLookup :: Embedded -> Pieces -> IO LookupResult
embeddedLookup Embedded
root Pieces
pieces =
    LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return (LookupResult -> IO LookupResult)
-> LookupResult -> IO LookupResult
forall a b. (a -> b) -> a -> b
$ Pieces -> Embedded -> LookupResult
elookup Pieces
pieces Embedded
root
  where
    elookup  :: Pieces -> Embedded -> LookupResult
    elookup :: Pieces -> Embedded -> LookupResult
elookup [] Embedded
x = Folder -> LookupResult
LRFolder (Folder -> LookupResult) -> Folder -> LookupResult
forall a b. (a -> b) -> a -> b
$ [Either FolderName File] -> Folder
Folder ([Either FolderName File] -> Folder)
-> [Either FolderName File] -> Folder
forall a b. (a -> b) -> a -> b
$ ((FolderName, EmbeddedEntry) -> Either FolderName File)
-> [(FolderName, EmbeddedEntry)] -> [Either FolderName File]
forall a b. (a -> b) -> [a] -> [b]
map (FolderName, EmbeddedEntry) -> Either FolderName File
toEntry ([(FolderName, EmbeddedEntry)] -> [Either FolderName File])
-> [(FolderName, EmbeddedEntry)] -> [Either FolderName File]
forall a b. (a -> b) -> a -> b
$ Embedded -> [(FolderName, EmbeddedEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Embedded
x
    elookup [FolderName
p] Embedded
x | Text -> Bool
T.null (FolderName -> Text
fromPiece FolderName
p) = Pieces -> Embedded -> LookupResult
elookup [] Embedded
x
    elookup (FolderName
p:Pieces
ps) Embedded
x =
        case FolderName -> Embedded -> Maybe EmbeddedEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FolderName
p Embedded
x of
            Maybe EmbeddedEntry
Nothing -> LookupResult
LRNotFound
            Just (EEFile ByteString
f) ->
                case Pieces
ps of
                    [] -> File -> LookupResult
LRFile (File -> LookupResult) -> File -> LookupResult
forall a b. (a -> b) -> a -> b
$ FolderName -> ByteString -> File
bsToFile FolderName
p ByteString
f
                    Pieces
_ -> LookupResult
LRNotFound
            Just (EEFolder Embedded
y) -> Pieces -> Embedded -> LookupResult
elookup Pieces
ps Embedded
y

toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
toEntry :: (FolderName, EmbeddedEntry) -> Either FolderName File
toEntry (FolderName
name, EEFolder{}) = FolderName -> Either FolderName File
forall a b. a -> Either a b
Left FolderName
name
toEntry (FolderName
name, EEFile ByteString
bs) = File -> Either FolderName File
forall a b. b -> Either a b
Right File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> FolderName
-> IO (Maybe ByteString)
-> Maybe EpochTime
-> File
File
    { fileGetSize :: Integer
fileGetSize = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs
    , fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h -> Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
s ResponseHeaders
h (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
    , fileName :: FolderName
fileName = FolderName
name
    , fileGetHash :: IO (Maybe ByteString)
fileGetHash = Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
runHash ByteString
bs
    , fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
    }

toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded
toEmbedded :: [(FilePath, ByteString)] -> Embedded
toEmbedded [(FilePath, ByteString)]
fps =
    [(Pieces, ByteString)] -> Embedded
go [(Pieces, ByteString)]
texts
  where
    texts :: [(Pieces, ByteString)]
texts = ((FilePath, ByteString) -> (Pieces, ByteString))
-> [(FilePath, ByteString)] -> [(Pieces, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FilePath
x, ByteString
y) -> ((FolderName -> Bool) -> Pieces -> Pieces
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FolderName -> Bool) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (FolderName -> Text) -> FolderName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FolderName -> Text
fromPiece) (Pieces -> Pieces) -> Pieces -> Pieces
forall a b. (a -> b) -> a -> b
$ FilePath -> Pieces
toPieces' FilePath
x, ByteString
y)) [(FilePath, ByteString)]
fps
    toPieces' :: FilePath -> Pieces
toPieces' FilePath
"" = []
    toPieces' FilePath
x =
        -- See https://github.com/yesodweb/yesod/issues/626
        --
        -- We want to separate on the forward slash on *all* OSes, and on
        -- Windows, also separate on a backslash.
        let (FilePath
y, FilePath
z) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isPathSeparator FilePath
x
         in Text -> FolderName
unsafeToPiece (FilePath -> Text
T.pack FilePath
y) FolderName -> Pieces -> Pieces
forall a. a -> [a] -> [a]
: FilePath -> Pieces
toPieces' (Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
z)

    go :: [(Pieces, ByteString)] -> Embedded
    go :: [(Pieces, ByteString)] -> Embedded
go [(Pieces, ByteString)]
orig =
        [(FolderName, EmbeddedEntry)] -> Embedded
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(FolderName, EmbeddedEntry)] -> Embedded)
-> [(FolderName, EmbeddedEntry)] -> Embedded
forall a b. (a -> b) -> a -> b
$ ((FolderName, [(Pieces, ByteString)])
 -> (FolderName, EmbeddedEntry))
-> [(FolderName, [(Pieces, ByteString)])]
-> [(FolderName, EmbeddedEntry)]
forall a b. (a -> b) -> [a] -> [b]
map (([(Pieces, ByteString)] -> EmbeddedEntry)
-> (FolderName, [(Pieces, ByteString)])
-> (FolderName, EmbeddedEntry)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [(Pieces, ByteString)] -> EmbeddedEntry
go') [(FolderName, [(Pieces, ByteString)])]
hoisted
      where
        next :: [(FolderName, (Pieces, ByteString))]
next = ((Pieces, ByteString) -> (FolderName, (Pieces, ByteString)))
-> [(Pieces, ByteString)] -> [(FolderName, (Pieces, ByteString))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pieces
x, ByteString
y) -> (Pieces -> FolderName
forall a. [a] -> a
head Pieces
x, (Pieces -> Pieces
forall a. [a] -> [a]
tail Pieces
x, ByteString
y))) [(Pieces, ByteString)]
orig
        grouped :: [[(Piece, ([Piece], ByteString))]]
        grouped :: [[(FolderName, (Pieces, ByteString))]]
grouped = ((FolderName, (Pieces, ByteString))
 -> (FolderName, (Pieces, ByteString)) -> Bool)
-> [(FolderName, (Pieces, ByteString))]
-> [[(FolderName, (Pieces, ByteString))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (FolderName -> FolderName -> Bool
forall a. Eq a => a -> a -> Bool
(==) (FolderName -> FolderName -> Bool)
-> ((FolderName, (Pieces, ByteString)) -> FolderName)
-> (FolderName, (Pieces, ByteString))
-> (FolderName, (Pieces, ByteString))
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (FolderName, (Pieces, ByteString)) -> FolderName
forall a b. (a, b) -> a
fst) ([(FolderName, (Pieces, ByteString))]
 -> [[(FolderName, (Pieces, ByteString))]])
-> [(FolderName, (Pieces, ByteString))]
-> [[(FolderName, (Pieces, ByteString))]]
forall a b. (a -> b) -> a -> b
$ ((FolderName, (Pieces, ByteString))
 -> (FolderName, (Pieces, ByteString)) -> Ordering)
-> [(FolderName, (Pieces, ByteString))]
-> [(FolderName, (Pieces, ByteString))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((FolderName, (Pieces, ByteString)) -> FolderName)
-> (FolderName, (Pieces, ByteString))
-> (FolderName, (Pieces, ByteString))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (FolderName, (Pieces, ByteString)) -> FolderName
forall a b. (a, b) -> a
fst) [(FolderName, (Pieces, ByteString))]
next
        hoisted :: [(Piece, [([Piece], ByteString)])]
        hoisted :: [(FolderName, [(Pieces, ByteString)])]
hoisted = ([(FolderName, (Pieces, ByteString))]
 -> (FolderName, [(Pieces, ByteString)]))
-> [[(FolderName, (Pieces, ByteString))]]
-> [(FolderName, [(Pieces, ByteString)])]
forall a b. (a -> b) -> [a] -> [b]
map ((FolderName, (Pieces, ByteString)) -> FolderName
forall a b. (a, b) -> a
fst ((FolderName, (Pieces, ByteString)) -> FolderName)
-> ([(FolderName, (Pieces, ByteString))]
    -> (FolderName, (Pieces, ByteString)))
-> [(FolderName, (Pieces, ByteString))]
-> FolderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FolderName, (Pieces, ByteString))]
-> (FolderName, (Pieces, ByteString))
forall a. [a] -> a
head ([(FolderName, (Pieces, ByteString))] -> FolderName)
-> ([(FolderName, (Pieces, ByteString))] -> [(Pieces, ByteString)])
-> [(FolderName, (Pieces, ByteString))]
-> (FolderName, [(Pieces, ByteString)])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((FolderName, (Pieces, ByteString)) -> (Pieces, ByteString))
-> [(FolderName, (Pieces, ByteString))] -> [(Pieces, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (FolderName, (Pieces, ByteString)) -> (Pieces, ByteString)
forall a b. (a, b) -> b
snd) [[(FolderName, (Pieces, ByteString))]]
grouped

    go' :: [(Pieces, ByteString)] -> EmbeddedEntry
    go' :: [(Pieces, ByteString)] -> EmbeddedEntry
go' [([], ByteString
content)] = ByteString -> EmbeddedEntry
EEFile ByteString
content
    go' [(Pieces, ByteString)]
x = Embedded -> EmbeddedEntry
EEFolder (Embedded -> EmbeddedEntry) -> Embedded -> EmbeddedEntry
forall a b. (a -> b) -> a -> b
$ [(Pieces, ByteString)] -> Embedded
go ([(Pieces, ByteString)] -> Embedded)
-> [(Pieces, ByteString)] -> Embedded
forall a b. (a -> b) -> a -> b
$ ((Pieces, ByteString) -> Bool)
-> [(Pieces, ByteString)] -> [(Pieces, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Pieces, ByteString)
y -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Pieces -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Pieces -> Bool) -> Pieces -> Bool
forall a b. (a -> b) -> a -> b
$ (Pieces, ByteString) -> Pieces
forall a b. (a, b) -> a
fst (Pieces, ByteString)
y) [(Pieces, ByteString)]
x

bsToFile :: Piece -> ByteString -> File
bsToFile :: FolderName -> ByteString -> File
bsToFile FolderName
name ByteString
bs = File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> FolderName
-> IO (Maybe ByteString)
-> Maybe EpochTime
-> File
File
    { fileGetSize :: Integer
fileGetSize = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
S.length ByteString
bs
    , fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h -> Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
s ResponseHeaders
h (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
    , fileName :: FolderName
fileName = FolderName
name
    , fileGetHash :: IO (Maybe ByteString)
fileGetHash = Maybe ByteString -> IO (Maybe ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ByteString -> IO (Maybe ByteString))
-> Maybe ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
runHash ByteString
bs
    , fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
    }

runHash :: ByteString -> ByteString
#ifdef MIN_VERSION_cryptonite
runHash :: ByteString -> ByteString
runHash = Base -> Digest MD5 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 (Digest MD5 -> ByteString)
-> (ByteString -> Digest MD5) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Digest MD5
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash :: S.ByteString -> Digest MD5)
#else
runHash = encode . hash
#endif