1 files changed, 73 insertions(+), 0 deletions(-)

A overlays/photo-hs/lib/Commands/Serve.hs

@@ 0,0 1,73 @@
+module Commands.Serve
+  ( commandServe
+  ) where
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
+import Database.Persist.Monad.Class (MonadSqlQuery)
+import qualified Options as O
+import qualified Photo as P
+import Servant ((:>), Get, JSON, Server, Application, serve, ServerT, hoistServer, Handler, (:<|>)(..))
+import Network.Wai.Handler.Warp (run)
+import Servant.API (Accept(..), MimeRender (..), Capture)
+import Network.HTTP.Media.MediaType ((//))
+import Data.Proxy (Proxy(..))
+import Data.ByteString.Lazy (ByteString)
+import AppData (AppData)
+import Control.Monad.Reader.Class (MonadReader)
+import Percept.Operations (inStorePathForPhoto)
+import Data.Functor ((<&>))
+import qualified Data.ByteString.Lazy as BSL
+import Data.Text.Lazy (Text)
+import qualified Data.Text.Lazy.Encoding as TL
+import Commands.List (commandList)
+import qualified Data.Text.Lazy as TL
+
+newtype PhotoData
+  = PhotoData
+  { _data :: ByteString
+  }
+
+data Image
+instance Accept Image where
+  contentType _ = "image" // "jxl"
+instance MimeRender Image PhotoData where
+  mimeRender _ photoData = photoData._data
+
+data HTML
+instance Accept HTML where
+  contentType _ = "text" // "html"
+instance MimeRender HTML Text where
+  mimeRender _ = TL.encodeUtf8
+
+
+type PerceptServeAPI
+     = "photo" :> Capture "hash" P.Hash :> Get '[Image] PhotoData
+  :<|> "index" :> Get '[HTML] Text
+
+servePhoto :: (MonadIO m, MonadReader AppData m) => P.Hash -> m PhotoData
+servePhoto hash = do
+  photoStorePath <- inStorePathForPhoto (P.Photo { hash = hash, imageType = "jxl" })
+  liftIO $ BSL.readFile photoStorePath <&> PhotoData
+
+serveIndex :: (MonadIO m, MonadReader AppData m) => [P.Photo] -> m Text
+serveIndex photos =
+  pure . TL.unlines $ map (TL.fromStrict . \photo ->
+                              let
+                                photoUrl = "/photo/" <> P.unHash photo.hash
+                                in
+                                "<a href=" <> photoUrl <> ">" <> photo.name <> "<img src=" <> photoUrl <>" height=100em> " <> "</a><br>"
+         ) photos
+
+perceptServer :: (MonadIO m, MonadReader AppData m) => [P.Photo] -> ServerT PerceptServeAPI m
+perceptServer photos
+     = servePhoto
+  :<|> serveIndex photos
+
+commandServe :: (MonadIO m, MonadUnliftIO m, MonadSqlQuery m, MonadReader AppData m) => O.Filter -> m ()
+commandServe filter = do
+  photos <- commandList filter
+
+  withRunInIO \unlift ->
+    run 8081 . serve (Proxy @PerceptServeAPI) $ hoistServer (Proxy @PerceptServeAPI) (liftIO . unlift) (perceptServer photos)
+
+  pure ()