{-# LANGUAGE CPP #-}

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

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

-- | 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 = embeddedLookup $ toEmbedded 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 a. a -> IO a
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 Piece File] -> Folder
Folder ([Either Piece File] -> Folder) -> [Either Piece File] -> Folder
forall a b. (a -> b) -> a -> b
$ ((Piece, EmbeddedEntry) -> Either Piece File)
-> [(Piece, EmbeddedEntry)] -> [Either Piece File]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Piece, EmbeddedEntry) -> Either Piece File
toEntry ([(Piece, EmbeddedEntry)] -> [Either Piece File])
-> [(Piece, EmbeddedEntry)] -> [Either Piece File]
forall a b. (a -> b) -> a -> b
$ Embedded -> [(Piece, EmbeddedEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList Embedded
x
    elookup [Piece
p] Embedded
x | Text -> Bool
T.null (Piece -> Text
fromPiece Piece
p) = Pieces -> Embedded -> LookupResult
elookup [] Embedded
x
    elookup (Piece
p : Pieces
ps) Embedded
x =
        case Piece -> Embedded -> Maybe EmbeddedEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Piece
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
$ Piece -> ByteString -> File
bsToFile Piece
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 :: (Piece, EmbeddedEntry) -> Either Piece File
toEntry (Piece
name, EEFolder{}) = Piece -> Either Piece File
forall a b. a -> Either a b
Left Piece
name
toEntry (Piece
name, EEFile ByteString
bs) =
    File -> Either Piece File
forall a b. b -> Either a b
Right
        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 :: Piece
fileName = Piece
name
            , fileGetHash :: IO (Maybe ByteString)
fileGetHash = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
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]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(FilePath
x, ByteString
y) -> ((Piece -> Bool) -> Pieces -> Pieces
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Piece -> Bool) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null (Text -> Bool) -> (Piece -> Text) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> 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 -> Piece
unsafeToPiece (FilePath -> Text
T.pack FilePath
y) Piece -> 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 =
        [(Piece, EmbeddedEntry)] -> Embedded
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Piece, EmbeddedEntry)] -> Embedded)
-> [(Piece, EmbeddedEntry)] -> Embedded
forall a b. (a -> b) -> a -> b
$ ((Piece, [(Pieces, ByteString)]) -> (Piece, EmbeddedEntry))
-> [(Piece, [(Pieces, ByteString)])] -> [(Piece, EmbeddedEntry)]
forall a b. (a -> b) -> [a] -> [b]
map (([(Pieces, ByteString)] -> EmbeddedEntry)
-> (Piece, [(Pieces, ByteString)]) -> (Piece, EmbeddedEntry)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [(Pieces, ByteString)] -> EmbeddedEntry
go') [(Piece, [(Pieces, ByteString)])]
hoisted
      where
        next :: [(Piece, (Pieces, ByteString))]
next = ((Pieces, ByteString) -> (Piece, (Pieces, ByteString)))
-> [(Pieces, ByteString)] -> [(Piece, (Pieces, ByteString))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Pieces
x, ByteString
y) -> (Pieces -> Piece
forall a. HasCallStack => [a] -> a
head Pieces
x, (Pieces -> Pieces
forall a. HasCallStack => [a] -> [a]
tail Pieces
x, ByteString
y))) [(Pieces, ByteString)]
orig
        grouped :: [[(Piece, ([Piece], ByteString))]]
        grouped :: [[(Piece, (Pieces, ByteString))]]
grouped = ((Piece, (Pieces, ByteString))
 -> (Piece, (Pieces, ByteString)) -> Bool)
-> [(Piece, (Pieces, ByteString))]
-> [[(Piece, (Pieces, ByteString))]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (Piece -> Piece -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Piece -> Piece -> Bool)
-> ((Piece, (Pieces, ByteString)) -> Piece)
-> (Piece, (Pieces, ByteString))
-> (Piece, (Pieces, ByteString))
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Piece, (Pieces, ByteString)) -> Piece
forall a b. (a, b) -> a
fst) ([(Piece, (Pieces, ByteString))]
 -> [[(Piece, (Pieces, ByteString))]])
-> [(Piece, (Pieces, ByteString))]
-> [[(Piece, (Pieces, ByteString))]]
forall a b. (a -> b) -> a -> b
$ ((Piece, (Pieces, ByteString))
 -> (Piece, (Pieces, ByteString)) -> Ordering)
-> [(Piece, (Pieces, ByteString))]
-> [(Piece, (Pieces, ByteString))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Piece, (Pieces, ByteString)) -> Piece)
-> (Piece, (Pieces, ByteString))
-> (Piece, (Pieces, ByteString))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Piece, (Pieces, ByteString)) -> Piece
forall a b. (a, b) -> a
fst) [(Piece, (Pieces, ByteString))]
next
        hoisted :: [(Piece, [([Piece], ByteString)])]
        hoisted :: [(Piece, [(Pieces, ByteString)])]
hoisted = ([(Piece, (Pieces, ByteString))]
 -> (Piece, [(Pieces, ByteString)]))
-> [[(Piece, (Pieces, ByteString))]]
-> [(Piece, [(Pieces, ByteString)])]
forall a b. (a -> b) -> [a] -> [b]
map ((Piece, (Pieces, ByteString)) -> Piece
forall a b. (a, b) -> a
fst ((Piece, (Pieces, ByteString)) -> Piece)
-> ([(Piece, (Pieces, ByteString))]
    -> (Piece, (Pieces, ByteString)))
-> [(Piece, (Pieces, ByteString))]
-> Piece
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Piece, (Pieces, ByteString))] -> (Piece, (Pieces, ByteString))
forall a. HasCallStack => [a] -> a
head ([(Piece, (Pieces, ByteString))] -> Piece)
-> ([(Piece, (Pieces, ByteString))] -> [(Pieces, ByteString)])
-> [(Piece, (Pieces, ByteString))]
-> (Piece, [(Pieces, ByteString)])
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((Piece, (Pieces, ByteString)) -> (Pieces, ByteString))
-> [(Piece, (Pieces, ByteString))] -> [(Pieces, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Piece, (Pieces, ByteString)) -> (Pieces, ByteString)
forall a b. (a, b) -> b
snd) [[(Piece, (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 a. [a] -> 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 :: Piece -> ByteString -> File
bsToFile Piece
name ByteString
bs =
    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 :: Piece
fileName = Piece
name
        , fileGetHash :: IO (Maybe ByteString)
fileGetHash = Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
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_crypton
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