Runtime.hs

{-# 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 files =
    (defaultFileServerSettings $ error "unused")
        { ssLookupFile = embeddedLookup $ toEmbedded files
        }

type Embedded = Map.Map Piece EmbeddedEntry

data EmbeddedEntry = EEFile ByteString | EEFolder Embedded

embeddedLookup :: Embedded -> Pieces -> IO LookupResult
embeddedLookup root pieces =
    return $ elookup pieces root
  where
    elookup :: Pieces -> Embedded -> LookupResult
    elookup [] x = LRFolder $ Folder $ fmap toEntry $ Map.toList x
    elookup [p] x | T.null (fromPiece p) = elookup [] x
    elookup (p : ps) x =
        case Map.lookup p x of
            Nothing -> LRNotFound
            Just (EEFile f) ->
                case ps of
                    [] -> LRFile $ bsToFile p f
                    _ -> LRNotFound
            Just (EEFolder y) -> elookup ps y

toEntry :: (Piece, EmbeddedEntry) -> Either FolderName File
toEntry (name, EEFolder{}) = Left name
toEntry (name, EEFile bs) =
    Right
        File
            { fileGetSize = fromIntegral $ S.length bs
            , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
            , fileName = name
            , fileGetHash = return $ Just $ runHash bs
            , fileGetModified = Nothing
            }

toEmbedded :: [(Prelude.FilePath, ByteString)] -> Embedded
toEmbedded fps =
    go texts
  where
    texts = fmap (\(x, y) -> (filter (not . T.null . fromPiece) $ toPieces' x, y)) fps
    toPieces' "" = []
    toPieces' 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 (y, z) = break isPathSeparator x
         in unsafeToPiece (T.pack y) : toPieces' (drop 1 z)

    go :: [(Pieces, ByteString)] -> Embedded
    go orig =
        Map.fromList $ map (second go') hoisted
      where
        next = map (\(x, y) -> (head x, (tail x, y))) orig
        grouped :: [[(Piece, ([Piece], ByteString))]]
        grouped = groupBy ((==) `on` fst) $ sortBy (comparing fst) next
        hoisted :: [(Piece, [([Piece], ByteString)])]
        hoisted = map (fst . head &&& map snd) grouped

    go' :: [(Pieces, ByteString)] -> EmbeddedEntry
    go' [([], content)] = EEFile content
    go' x = EEFolder $ go $ filter (\y -> not $ null $ fst y) x

bsToFile :: Piece -> ByteString -> File
bsToFile name bs =
    File
        { fileGetSize = fromIntegral $ S.length bs
        , fileToResponse = \s h -> W.responseBuilder s h $ byteString bs
        , fileName = name
        , fileGetHash = return $ Just $ runHash bs
        , fileGetModified = Nothing
        }

runHash :: ByteString -> ByteString
#ifdef MIN_VERSION_crypton
runHash = convertToBase Base64 . (hash :: S.ByteString -> Digest MD5)
#else
runHash = encode . hash
#endif