Create RestService, with state and an eval endpoint

4 files changed, 94 insertions, 15 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 971bed7..3bea66c 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,6 +1,6 @@
 module Main where
 
-import qualified BizExpr (eval, repl)
+import qualified RestService (start)
 
 main :: IO ()
-main = BizExpr.repl
+main = RestService.start
diff --git a/hs.cabal b/hs.cabal
index aec9be4..700d609 100644
--- a/hs.cabal
+++ b/hs.cabal
@@ -22,14 +22,22 @@ maintainer:         [email protected]
 extra-source-files: CHANGELOG.md
 
 library
-    exposed-modules:  BizExpr
+    exposed-modules: RestService 
 
     -- Modules included in this library but not exported.
-    -- other-modules:
+    other-modules: BizExpr
 
     -- LANGUAGE extensions used by modules in this package.
     -- other-extensions:
-    build-depends:    base ^>=4.14.1.0
+    build-depends:    base ^>=4.14.1.0,
+                      text,
+                      wai,
+                      http-types,
+                      warp,
+                      aeson,
+                      scotty,
+                      containers,
+                      stm
     hs-source-dirs:   src
     default-language: Haskell2010
 
diff --git a/src/BizExpr.hs b/src/BizExpr.hs
index c297da6..0ccfcd3 100644
--- a/src/BizExpr.hs
+++ b/src/BizExpr.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleInstances #-}
+
 module BizExpr (repl, eval) where
 
 import Data.Maybe (fromMaybe)
@@ -6,9 +8,9 @@ import Text.Read (readMaybe)
 --import Data.Text as T
 
 repl :: IO ()
-repl = getLine >>= putStrLn . maybe "Failed to evaluate expression" show . eval >> repl
+repl = getLine >>= putStrLn . maybe "Failed to evaluate expression" show . (eval :: String -> Maybe Integer) >> repl
 
-eval :: String -> Maybe Integer
+eval :: CoerceTo a => String -> Maybe a
 eval x = coerceTo =<< evalAst . head . fst =<< parseLevel x
 
 data Value = IntVal Integer | StrVal String | BoolVal Bool
@@ -26,12 +28,18 @@ instance CoerceTo Integer where
 
   coerceFrom = IntVal
 
+instance CoerceTo String where
+  coerceTo (BoolVal v) = Just $ show v
+  coerceTo (IntVal v) = Just $ show v
+  coerceTo (StrVal v) = Just v
+  coerceFrom = StrVal
+
 instance CoerceTo Bool where
+  coerceTo (BoolVal v) = Just v
   coerceTo (IntVal v) = Just $ v /= 0
   coerceTo (StrVal "True") = Just True
   coerceTo (StrVal "true") = Just True
-  coerceTo (BoolVal v) = Just v
-  coerceTo _ = Just False
+  coerceTo v = coerceTo . IntVal =<< coerceTo v
 
   coerceFrom = BoolVal
 
@@ -46,12 +54,16 @@ parseLevel :: String -> Maybe ([Ast], String)
 parseLevel = go "" (Just [])
   where
     go :: String -> Maybe [Ast] -> String -> Maybe ([Ast], String)
-    go prev (Just l) ('(' : next) = case parseLevel next of
-      Nothing ->
-        Nothing
-      Just (arg, remnant) ->
-        let r = if remnant /= "" && head remnant == ',' then tail remnant else remnant
-         in go "" (Just (l ++ [Expr prev arg])) r
+    go prev (Just l) ('(' : next) =
+      case parseLevel next of
+        Nothing ->
+          Nothing
+        Just (arg, remnant) ->
+          let r =
+                if remnant /= "" && head remnant == ','
+                  then tail remnant
+                  else remnant
+           in go "" (Just (l ++ [Expr prev arg])) r
     go prev (Just l) (')' : remnant) =
       let l0 = [Val $ StrVal prev | prev /= ""]
        in Just (l ++ l0, remnant)
diff --git a/src/RestService.hs b/src/RestService.hs
new file mode 100644
index 0000000..2921687
--- /dev/null
+++ b/src/RestService.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+module RestService (start) where
+
+import Network.HTTP.Types.URI
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Data.Aeson (FromJSON, ToJSON)
+import Web.Scotty as S
+import Data.Maybe (fromMaybe)
+import GHC.Generics
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TArray
+
+import qualified BizExpr as E
+import qualified Data.Text.Lazy as L
+import qualified Data.Text as T
+import qualified Data.Map as M
+import qualified Network.HTTP.Types.Status as Status
+
+staticFilePaths :: [FilePath]
+staticFilePaths = map ("./static/" ++) ["materialize.min.css", "materialize.min.js", "service.js"]
+
+staticFiles :: ScottyM ()
+staticFiles = do
+  --    get "/static/:file" $ file
+  mapM_ addFile staticFilePaths
+  where
+    addFile path = get (capture $ tail path) $ file path
+
+data ExprReq = ExprReq {expression :: L.Text, result :: Maybe L.Text}
+    deriving (Show, Generic)
+instance FromJSON ExprReq
+
+numInc :: State -> IO Int
+numInc s = atomically (readTVar s >>= writeTVar s . (+1) >> readTVar s)
+
+routes :: State -> ScottyM ()
+routes state = do
+  staticFiles
+  get "/num" $
+    S.json =<< liftAndCatchIO (numInc state)
+  get "/:expr" $
+    S.text =<< S.param "expr"
+  post "/eval" $
+    S.text . L.pack . fromMaybe "failure" . E.eval . L.unpack . expression =<< S.jsonData
+
+type State = TVar Int
+
+start :: IO ()
+start = scottyOpts opts . routes =<< newTVarIO 3
+
+opts :: Options
+opts = Options 1 settings
+  where
+    settings = setPort 3000 defaultSettings