{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Handler
  ( getVarsR
  , getVarR
  , postVarsR
  , putVarR
  , deleteVarR
  , postEvalR
  ) where

import Control.Monad.IO.Class (liftIO)
import Data.Aeson ((.=), object, toJSON)
import Data.Bool (bool)
import qualified Data.Map as Map
import Data.Maybe (catMaybes, isNothing, maybeToList)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time (getCurrentTime)
import Database.Persist
  ( Entity(entityKey, entityVal)
  , Filter
  , SelectOpt(Asc, Desc, LimitTo)
  , (=.)
  , (==.)
  , deleteBy
  , getBy
  , insert
  , selectList
  , update
  )
import Network.HTTP.Types (status400, status500)
import Yesod
  ( TypedContent
  , defaultLayout
  , lookupGetParam
  , provideRep
  , requireCheckJsonBody
  , selectRep
  , sendResponseStatus
  , whamlet
  , whamletFile
  )
import Yesod.Persist (getBy404, runDB)

import Expr
import Foundation
import qualified Model.PostEvalRequest as PostEvalRequest
import qualified Model.PutVariableRequest as PutVariableRequest

-------------------------------------------------------------------------------
-- Get variable(s)
-------------------------------------------------------------------------------

-- | Handle @\/variables GET@ requests by returning the variables specified by
-- the filter and limit conditions specified in the query parameters, and
-- sorted by the field specified in the query parameters.
getVarsR :: Handler TypedContent
getVarsR :: Handler TypedContent
getVarsR = do
  [Entity Variable]
entities <- forall record backend (m :: * -> *).
(MonadIO m, PersistQueryRead backend,
 PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m [Entity record]
selectList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler [Filter Variable]
getFilters forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handler [SelectOpt Variable]
getSelectOpts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB
  let variables :: [Variable]
variables = forall a b. (a -> b) -> [a] -> [b]
map forall record. Entity record -> record
entityVal [Entity Variable]
entities
  forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON [Variable]
variables))
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout $(whamletFile "templates/variables-table.hamlet"))

-- | Handle @\/variables\/{name} GET@ requests for a single variable name by
-- returning the variable with that name, if it exists. If it does not exist, a
-- 404 error response is returned.
getVarR :: Text -> Handler TypedContent
getVarR :: Text -> Handler TypedContent
getVarR Text
name = do
  Entity Variable
entity <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend val (m :: * -> *).
(PersistUniqueRead backend, PersistRecordBackend val backend,
 MonadIO m) =>
Unique val -> ReaderT backend m (Entity val)
getBy404 (Text -> Unique Variable
UniqueName Text
name))
  forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep (forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> Value
toJSON (forall record. Entity record -> record
entityVal Entity Variable
entity)))
    forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ do
      let variables :: [Variable]
variables = [forall record. Entity record -> record
entityVal Entity Variable
entity]
      forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout $(whamletFile "templates/variables-table.hamlet")

getFilters :: Handler [Filter Variable]
getFilters :: Handler [Filter Variable]
getFilters = forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall typ. (typ ~ Text) => EntityField Variable typ
VariableName forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==.) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"name"

getSelectOpts :: Handler [SelectOpt Variable]
getSelectOpts :: Handler [SelectOpt Variable]
getSelectOpts = do
  Maybe Text
maybeSortBy <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"sort"
  Maybe Text
maybeDesc <- forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"desc"
  let maybeSort :: Maybe (SelectOpt Variable)
maybeSort =
        Maybe Text
maybeSortBy forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall t. EntityField Variable t -> SelectOpt Variable)
-> Text -> Maybe (SelectOpt Variable)
resolveField (forall a. a -> a -> Bool -> a
bool forall record typ. EntityField record typ -> SelectOpt record
Desc forall record typ. EntityField record typ -> SelectOpt record
Asc (forall a. Maybe a -> Bool
isNothing Maybe Text
maybeDesc))
  Maybe (SelectOpt Variable)
maybeLimit <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall record. Int -> SelectOpt record
LimitTo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadHandler m => Text -> m (Maybe Text)
lookupGetParam Text
"limit"
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [Maybe a] -> [a]
catMaybes [Maybe (SelectOpt Variable)
maybeSort, Maybe (SelectOpt Variable)
maybeLimit])
  where
    resolveField ::
         (forall t. EntityField Variable t -> SelectOpt Variable)
      -> Text
      -> Maybe (SelectOpt Variable)
    resolveField :: (forall t. EntityField Variable t -> SelectOpt Variable)
-> Text -> Maybe (SelectOpt Variable)
resolveField forall t. EntityField Variable t -> SelectOpt Variable
sortOrder Text
"name" = forall a. a -> Maybe a
Just (forall t. EntityField Variable t -> SelectOpt Variable
sortOrder forall typ. (typ ~ Text) => EntityField Variable typ
VariableName)
    resolveField forall t. EntityField Variable t -> SelectOpt Variable
sortOrder Text
"value" = forall a. a -> Maybe a
Just (forall t. EntityField Variable t -> SelectOpt Variable
sortOrder forall typ. (typ ~ Double) => EntityField Variable typ
VariableValue)
    resolveField forall t. EntityField Variable t -> SelectOpt Variable
sortOrder Text
"created" = forall a. a -> Maybe a
Just (forall t. EntityField Variable t -> SelectOpt Variable
sortOrder forall typ. (typ ~ UTCTime) => EntityField Variable typ
VariableCreated)
    resolveField forall t. EntityField Variable t -> SelectOpt Variable
sortOrder Text
"updated" = forall a. a -> Maybe a
Just (forall t. EntityField Variable t -> SelectOpt Variable
sortOrder forall typ. (typ ~ UTCTime) => EntityField Variable typ
VariableUpdated)
    resolveField forall t. EntityField Variable t -> SelectOpt Variable
_ Text
_ = forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
-- Create/update/delete variable(s)
-------------------------------------------------------------------------------

-- | Handle @\/variables POST@ requests by creating or updating multiple
-- variables at once. The variables to be updated are specified in the request
-- body, which is a JSON object whose keys are variable names and values are
-- the corresponding values. E.g.
--
-- > {"a": 10, "b": -0.5}
postVarsR :: Handler ()
postVarsR :: Handler ()
postVarsR = forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireCheckJsonBody forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Double -> Handler ()
setVariable) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList

-- | Handle @\/variables\/{name} PUT@ requests by creating or updating a single
-- variable. The name of the variable to be updated is specified in the request
-- URL slug, and the value to assign to that variable is represented in the
-- request body as a JSON object of the form
--
-- > {"value": 100}
putVarR :: Text -> Handler ()
putVarR :: Text -> Handler ()
putVarR Text
name =
  forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireCheckJsonBody forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Double -> Handler ()
setVariable Text
name forall b c a. (b -> c) -> (a -> b) -> a -> c
. PutVariableRequest -> Double
PutVariableRequest.value

-- | Handle @\/variables/{name} DELETE@ requests by deleting the variable with
-- the given name. If a variable with the given name doesn't exist, nothing
-- happens.
deleteVarR :: Text -> Handler ()
deleteVarR :: Text -> Handler ()
deleteVarR Text
name = forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m ()
deleteBy (Text -> Unique Variable
UniqueName Text
name))

setVariable :: Text -> Double -> Handler ()
setVariable :: Text -> Double -> Handler ()
setVariable Text
name Double
value
  | Text -> Bool
isValidName Text
name = do
    UTCTime
time <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Maybe (Entity Variable)
maybeEntity <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy (Text -> Unique Variable
UniqueName Text
name))
    case Maybe (Entity Variable)
maybeEntity of
      Maybe (Entity Variable)
Nothing -> do
        let variable :: Variable
variable = Text -> Double -> UTCTime -> UTCTime -> Variable
Variable Text
name Double
value UTCTime
time UTCTime
time
        Key Variable
_ <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
record -> ReaderT backend m (Key record)
insert Variable
variable)
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just Entity Variable
entity -> do
        let updates :: [Update Variable]
updates = [forall typ. (typ ~ Double) => EntityField Variable typ
VariableValue forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Double
value, forall typ. (typ ~ UTCTime) => EntityField Variable typ
VariableUpdated forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
time]
        forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB forall a b. (a -> b) -> a -> b
$ forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update (forall record. Entity record -> Key record
entityKey Entity Variable
entity) [Update Variable]
updates
setVariable Text
name Double
_
  | Bool
otherwise = forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status400 (Text -> Text -> Text
Text.append Text
"Invalid name: " Text
name)

-------------------------------------------------------------------------------
-- Evaluate an expression
-------------------------------------------------------------------------------

-- | Handle @\/ POST@ requests by evaluating the expression in the request
-- body, which should be a JSON object like
--
-- > {"expr": "a*b + 100/(c-d)"}
--
-- If any of the variables occurring in the expression aren't defined in the
-- variable store, then a 404 is returned.
postEvalR :: Handler TypedContent
postEvalR :: Handler TypedContent
postEvalR = do
  PostEvalRequest
request <- forall (m :: * -> *) a. (MonadHandler m, FromJSON a) => m a
requireCheckJsonBody
  case (forall s. Stream s Identity Char => s -> Either ParseError Expr
parseExpr (PostEvalRequest -> Text
PostEvalRequest.expr PostEvalRequest
request)) of
    Left ParseError
err -> forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status400 (forall a. Show a => a -> String
show ParseError
err)
    Right Expr
expr -> do
      Map Text Double
env <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Text -> Handler (Text, Double)
loadVar (forall a. Set a -> [a]
Set.toList (Expr -> Set Text
variablesOf Expr
expr)))
      case (Map Text Double -> Expr -> Maybe Double
evaluateExpr Map Text Double
env Expr
expr) of
        Maybe Double
Nothing ->
          forall (m :: * -> *) c a.
(MonadHandler m, ToTypedContent c) =>
Status -> c -> m a
sendResponseStatus Status
status500 (Text
"Unknown error occurred" :: Text)
        Just Double
value ->
          forall (m :: * -> *).
MonadHandler m =>
Writer (Endo [ProvidedRep m]) () -> m TypedContent
selectRep forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ [Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Double
value]
            forall (m :: * -> *) a.
(Monad m, HasContentType a) =>
m a -> Writer (Endo [ProvidedRep m]) ()
provideRep forall a b. (a -> b) -> a -> b
$ forall site.
Yesod site =>
WidgetFor site () -> HandlerFor site Html
defaultLayout [whamlet|#{show value}|]
  where
    loadVar :: Text -> Handler (Text, Double)
    loadVar :: Text -> Handler (Text, Double)
loadVar Text
name = do
      Entity Variable
entity <- forall site a.
YesodPersist site =>
YesodDB site a -> HandlerFor site a
runDB (forall backend val (m :: * -> *).
(PersistUniqueRead backend, PersistRecordBackend val backend,
 MonadIO m) =>
Unique val -> ReaderT backend m (Entity val)
getBy404 (Text -> Unique Variable
UniqueName Text
name))
      let variable :: Variable
variable = forall record. Entity record -> record
entityVal Entity Variable
entity
      forall (m :: * -> *) a. Monad m => a -> m a
return (Variable -> Text
variableName Variable
variable, Variable -> Double
variableValue Variable
variable)