{-#LANGUAGE NoImplicitPrelude #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE TypeFamilies #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE LambdaCase #-}
{-#LANGUAGE DeriveGeneric #-}
{-#LANGUAGE DeriveFunctor #-}
{-#LANGUAGE TypeApplications #-}
module Web.Sprinkles.Backends.Data
( BackendData (..)
, BackendMeta (..)
, BackendSource (..)
, Verification (..)
, RawBytes (..)
, toBackendData
, Items (..)
, reduceItems
, addBackendDataChildren
, rawToLBS
, rawFromLBS
, serializeBackendSource
, deserializeBackendSource
)
where
import Web.Sprinkles.Prelude
import Text.Ginger (ToGVal (..), GVal, Run (..), dict, (~>))
import qualified Text.Ginger as Ginger
import Data.Aeson as JSON
import Data.Aeson.TH as JSON
import Data.Yaml as YAML
import qualified Data.Serialize as Cereal
import Data.Serialize (Serialize)
import Foreign.C.Types (CTime (..))
import Network.Mime (MimeType)
import Data.Default (Default (..))
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import Data.Time (UTCTime, LocalTime, utc, utcToLocalTime)
import Data.Scientific (Scientific)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy.Char8 as LBS8
import Text.Printf (printf)
import Data.Foldable (Foldable (foldMap))
import Web.Sprinkles.Backends.Spec
unCTime :: CTime -> Int
unCTime (CTime i) = fromIntegral i
data Items a = NotFound
| SingleItem a
| MultiItem [a]
deriving (Functor)
instance Foldable Items where
foldMap f NotFound = mempty
foldMap f (SingleItem x) = f x
foldMap f (MultiItem xs) = mconcat $ map f xs
reduceItems :: FetchMode -> [a] -> Items a
reduceItems FetchOne [] = NotFound
reduceItems FetchOne (x:_) = SingleItem x
reduceItems FetchAll xs = MultiItem xs
reduceItems (FetchN n) xs = MultiItem $ take n xs
instance ToGVal m a => ToGVal m (Items a) where
toGVal NotFound = def
toGVal (SingleItem x) = toGVal x
toGVal (MultiItem xs) = toGVal xs
instance ToJSON a => ToJSON (Items a) where
toJSON NotFound = Null
toJSON (SingleItem x) = toJSON x
toJSON (MultiItem xs) = toJSON xs
data RawBytes =
RawBytes
{ rbLength :: IO Integer
, rbGetRange :: Integer -> Integer -> IO LByteString
}
rawFromLBS :: LByteString -> RawBytes
rawFromLBS b =
RawBytes
{ rbLength = return . fromIntegral $ length b
, rbGetRange = \start len ->
return
. take (fromIntegral len)
. drop (fromIntegral start)
$ b
}
rawToLBS :: RawBytes -> IO LByteString
rawToLBS r = do
len <- rbLength r
rbGetRange r 0 len
rawToGVal :: MonadIO m => RawBytes -> GVal (Run p m h)
rawToGVal raw =
dict
[ ("length", Ginger.fromFunction (gfnLength raw))
, ("read", Ginger.fromFunction (gfnRead raw))
, ("store", Ginger.fromFunction (gfnStore raw))
]
where
gfnLength :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h))
gfnLength raw args = do
length <- liftIO (rbLength raw)
return . toGVal $ length
gfnRead :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h))
gfnRead raw args = do
inputLength <- liftIO (rbLength raw)
let extracted =
Ginger.extractArgsDefL
[ ("start", def)
, ("length", toGVal inputLength)
]
args
case extracted of
Right [startG, lengthG] -> do
let start = fromMaybe 0 $ asInteger startG
length = fromMaybe inputLength $ asInteger lengthG
bytes <- liftIO (rbGetRange raw start length)
return . toGVal . LBS8.unpack $ bytes
_ -> fail "Invalid arguments to RawBytes.read"
gfnStore :: MonadIO m => RawBytes -> [(Maybe Text, GVal (Run p m h))] -> Run p m h (GVal (Run p m h))
gfnStore raw args = do
let extracted =
Ginger.extractArgsDefL
[ ("filename", "stored")
]
args
case extracted of
Right [filenameG] -> liftIO $ do
let filename = unpack . Ginger.asText $ filenameG
len <- rbLength raw
bytes <- rbGetRange raw 0 len
LBS8.writeFile filename bytes
return . toGVal $ True
_ -> fail "Invalid arguments to RawBytes.store"
asInteger :: GVal m -> Maybe Integer
asInteger = fmap round . Ginger.asNumber
instance MonadIO m => ToGVal (Run p m h) RawBytes where
toGVal = rawToGVal
data BackendData p m h =
BackendData
{ bdJSON :: JSON.Value
, bdGVal :: GVal (Run p m h)
, bdRaw :: RawBytes
, bdMeta :: BackendMeta
, bdChildren :: HashMap Text (BackendData p m h)
, bdVerification :: Verification
}
data Verification
= Trusted
| VerifyCSRF
deriving (Show, Eq, Enum, Ord, Bounded)
data BackendSource =
BackendSource
{ bsMeta :: BackendMeta
, bsSource :: RawBytes
, bsVerification :: Verification
}
deriving (Generic)
data SerializableBackendSource =
SerializableBackendSource
{ sbsMeta :: BackendMeta
, sbsSource :: LByteString
}
deriving (Generic)
instance Serialize SerializableBackendSource where
serializeBackendSource :: BackendSource -> IO SerializableBackendSource
serializeBackendSource bs = do
srcBytes <- rawToLBS . bsSource $ bs
return $ SerializableBackendSource (bsMeta bs) srcBytes
deserializeBackendSource :: SerializableBackendSource -> BackendSource
deserializeBackendSource sbs =
BackendSource (sbsMeta sbs) (rawFromLBS $ sbsSource sbs) Trusted
toBackendData :: (ToJSON a, ToGVal (Run p m h) a) => BackendSource -> a -> BackendData p m h
toBackendData src val =
BackendData
{ bdJSON = toJSON val
, bdGVal = toGVal val
, bdRaw = bsSource src
, bdMeta = bsMeta src
, bdChildren = mapFromList []
, bdVerification = bsVerification src
}
addBackendDataChildren :: HashMap Text (BackendData p m h)
-> BackendData p m h
-> BackendData p m h
addBackendDataChildren children bd =
bd { bdChildren = children <> bdChildren bd }
instance ToJSON (BackendData p m h) where
toJSON = bdJSON
instance MonadIO m => ToGVal (Run p m h) (BackendData p m h) where
toGVal bd =
let baseVal = bdGVal bd
baseLookup = fromMaybe (const def) $ Ginger.asLookup baseVal
baseDictItems = Ginger.asDictItems baseVal
children = bdChildren bd
childrenG = toGVal children
in baseVal
{ Ginger.asLookup = Just $ \case
"props" -> return . toGVal . bdMeta $ bd
"children" -> return childrenG
"bytes" -> return . toGVal . bdRaw $ bd
k -> baseLookup k
, Ginger.asDictItems =
(("props" ~> bdMeta bd):) .
(("bytes" ~> bdRaw bd):) .
(("children", childrenG):) <$> baseDictItems
}
data BackendMeta =
BackendMeta
{ bmMimeType :: MimeType
, bmMTime :: Maybe POSIXTime
, bmName :: Text
, bmPath :: Text
, bmSize :: Maybe Integer
}
deriving (Show, Generic)
instance Serialize BackendMeta where
put bm = do
Cereal.put $ bmMimeType bm
Cereal.put . fmap fromEnum $ bmMTime bm
Cereal.put . encodeUtf8 $ bmName bm
Cereal.put . encodeUtf8 $ bmPath bm
Cereal.put $ bmSize bm
get =
BackendMeta <$> Cereal.get
<*> (fmap toEnum <$> Cereal.get)
<*> (decodeUtf8 <$> Cereal.get)
<*> (decodeUtf8 <$> Cereal.get)
<*> Cereal.get
mtimeFlavors :: BackendMeta -> (Maybe POSIXTime, Maybe Scientific, Maybe LocalTime)
mtimeFlavors bm =
let mtime = bmMTime bm
in ( mtime
, realToFrac <$> mtime :: Maybe Scientific
, utcToLocalTime utc . posixSecondsToUTCTime <$> mtime
)
instance ToJSON BackendMeta where
toJSON bm =
let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm
in JSON.object
[ "mimeType" .= decodeUtf8 @Text (bmMimeType bm)
, "mtime" .= mtimeSci
, "mtimeUTC" .= mtimeUTC
, "name" .= bmName bm
, "path" .= bmPath bm
, "size" .= bmSize bm
]
instance ToGVal m BackendMeta where
toGVal bm =
let (mtime, mtimeSci, mtimeUTC) = mtimeFlavors bm
in Ginger.dict
[ "type" ~> decodeUtf8 @Text (bmMimeType bm)
, "mtime" ~> mtimeSci
, "mtimeUTC" ~> mtimeUTC
, "name" ~> bmName bm
, "path" ~> bmPath bm
, "size" ~> bmSize bm
]