{-# 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 (groupBy, sortBy)
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_crypton
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 forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => FilePath -> a
error FilePath
"unused")
    { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = Embedded -> Pieces -> IO LookupResult
embeddedLookup 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 =
    forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ [Either Piece File] -> Folder
Folder 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 forall a b. (a -> b) -> a -> b
$ 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 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 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{}) = forall a b. a -> Either a b
Left Piece
name
toEntry (Piece
name, EEFile ByteString
bs) = forall a b. b -> Either a b
Right File
    { fileGetSize :: Integer
fileGetSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
    , fileName :: Piece
fileName = Piece
name
    , fileGetHash :: IO (Maybe ByteString)
fileGetHash = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
runHash ByteString
bs
    , fileGetModified :: Maybe EpochTime
fileGetModified = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(FilePath
x, ByteString
y) -> (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> Text
fromPiece) 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isPathSeparator FilePath
x
         in Text -> Piece
unsafeToPiece (FilePath -> Text
T.pack FilePath
y) forall a. a -> [a] -> [a]
: FilePath -> Pieces
toPieces' (forall a. Int -> [a] -> [a]
drop Int
1 FilePath
z)

    go :: [(Pieces, ByteString)] -> Embedded
    go :: [(Pieces, ByteString)] -> Embedded
go [(Pieces, ByteString)]
orig =
        forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a b. (a -> b) -> [a] -> [b]
map (\(Pieces
x, ByteString
y) -> (forall a. [a] -> a
head Pieces
x, (forall a. [a] -> [a]
tail Pieces
x, ByteString
y))) [(Pieces, ByteString)]
orig
        grouped :: [[(Piece, ([Piece], ByteString))]]
        grouped :: [[(Piece, (Pieces, ByteString))]]
grouped = forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) [(Piece, (Pieces, ByteString))]
next
        hoisted :: [(Piece, [([Piece], ByteString)])]
        hoisted :: [(Piece, [(Pieces, ByteString)])]
hoisted = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (a -> b) -> [a] -> [b]
map 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 forall a b. (a -> b) -> a -> b
$ [(Pieces, ByteString)] -> Embedded
go forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\(Pieces, ByteString)
y -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs
    , fileName :: Piece
fileName = Piece
name
    , fileGetHash :: IO (Maybe ByteString)
fileGetHash = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
runHash ByteString
bs
    , fileGetModified :: Maybe EpochTime
fileGetModified = forall a. Maybe a
Nothing
    }

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