1 files changed, 51 insertions, 0 deletions
diff --git a/hsm-web/Hsm/Web.hs b/hsm-web/Hsm/Web.hs
new file mode 100644
index 0000000..975f556
--- /dev/null
+++ b/hsm-web/Hsm/Web.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Hsm.Web
+  ( Web
+  , runServer
+  , runWeb
+  ) where
+
+import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
+import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unEff, unsafeEff)
+import Effectful.Dispatch.Static.Primitive (Env)
+import Effectful.Exception (finally)
+import Hsm.Cam (Cam, capturePng)
+import Hsm.Log (Log, Severity(Info, Trace), logMsg, makeLoggerIO)
+import Network.Wai.Handler.Warp (defaultSettings, setLogger)
+import Paths_hsm_web (getDataFileName)
+import Web.Scotty (Options(settings, verbose), defaultOptions, file, get, liftIO, raw, scottyOpts, setHeader)
+
+data Web (a :: * -> *) (b :: *)
+
+type instance DispatchOf Web = Static WithSideEffects
+
+newtype instance StaticRep Web =
+  Web Options
+
+server :: (Cam :> es, Log "cam" :> es) => Options -> Env es -> IO ()
+server options env = do
+  index <- getDataFileName "Html/index.html"
+  scottyOpts options $ do
+    get "/" $ file index
+    get "/cam.png" $ do
+      setHeader "Content-Type" "image/png"
+      liftIO (unEff capturePng env) >>= raw
+
+runServer :: (Cam :> es, Log "cam" :> es, Log "web" :> es, Web :> es) => Eff es ()
+runServer = finally startServer stopServer
+  where
+    startServer = do
+      Web options <- getStaticRep
+      logMsg @"web" Info "Starting scotty web server"
+      unsafeEff $ server options
+    stopServer = logMsg @"web" Info "Stopping scotty web server"
+
+runWeb :: (IOE :> es, Log "scotty" :> es, Log "web" :> es) => Eff (Web : es) a -> Eff es a
+runWeb action = do
+  logMsg @"web" Info "Registering logger for scotty web server"
+  scottyLogger <- makeLoggerIO @"scotty" >>= return . logRequest
+  evalStaticRep (Web $ defaultOptions {verbose = 0, settings = setLogger scottyLogger defaultSettings}) action
+  where
+    logRequest loggerIO request status fileSize = loggerIO Trace $ unwords [show request, show status, show fileSize]