diff options
Diffstat (limited to 'users/Profpatsch/cas-serve/CasServe.hs')
| -rw-r--r-- | users/Profpatsch/cas-serve/CasServe.hs | 114 |
1 files changed, 57 insertions, 57 deletions
diff --git a/users/Profpatsch/cas-serve/CasServe.hs b/users/Profpatsch/cas-serve/CasServe.hs index 3e658e58cc..62636fe9c1 100644 --- a/users/Profpatsch/cas-serve/CasServe.hs +++ b/users/Profpatsch/cas-serve/CasServe.hs @@ -1,49 +1,47 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main where +import ArglibNetencode (arglibNetencode) import Control.Applicative -import qualified Crypto.Hash as Crypto -import qualified Data.ByteArray as ByteArray -import qualified Data.ByteString.Lazy as ByteString.Lazy -import qualified Data.ByteString.Lazy as Lazy +import Control.Monad.Reader +import Crypto.Hash qualified as Crypto +import Data.ByteArray qualified as ByteArray +import Data.ByteString.Lazy qualified as ByteString.Lazy +import Data.ByteString.Lazy qualified as Lazy import Data.Functor.Compose import Data.Int (Int64) -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import qualified Data.Text as Text -import qualified Data.Text.IO as Text +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.IO qualified as Text import Database.SQLite.Simple (NamedParam ((:=))) -import qualified Database.SQLite.Simple as Sqlite -import qualified Database.SQLite.Simple.FromField as Sqlite -import qualified Database.SQLite.Simple.QQ as Sqlite -import GHC.TypeLits (Symbol) -import MyPrelude -import qualified Network.HTTP.Types as Http -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import qualified SuperRecord as Rec +import Database.SQLite.Simple qualified as Sqlite +import Database.SQLite.Simple.FromField qualified as Sqlite +import Database.SQLite.Simple.QQ qualified as Sqlite +import Label +import Netencode.Parse qualified as Net +import Network.HTTP.Types qualified as Http +import Network.Wai qualified as Wai +import Network.Wai.Handler.Warp qualified as Warp +import PossehlAnalyticsPrelude import System.IO (stderr) -import Control.Monad.Reader + +parseArglib = do + let env = label @"arglibEnvvar" "CAS_SERVE_ARGS" + let asApi = + Net.asRecord >>> do + address <- label @"bindToAddress" <$> (Net.key "bindToAddress" >>> Net.asText) + port <- label @"port" <$> (Net.key "port" >>> Net.asText) + pure (T2 address port) + arglibNetencode "cas-serve" (Just env) + <&> Net.runParse + [fmt|Cannot parse arguments in "{env.arglibEnvvar}"|] + ( Net.asRecord >>> do + publicApi <- label @"publicApi" <$> (Net.key "publicApi" >>> asApi) + privateApi <- label @"privateApi" <$> (Net.key "privateApi" >>> asApi) + pure $ T2 publicApi privateApi + ) main :: IO () main = do @@ -75,8 +73,7 @@ api env req respond = do Wai.responseLBS Http.status200 headers - ( body & toLazyBytes - ) + (body & toLazyBytes) data Env = Env { envWordlist :: Sqlite.Connection, @@ -85,7 +82,7 @@ data Env = Env -- | I don’t need any fancy routing in this, so a handler is just something that returns a @Just (IO a)@ if it wants to handle the request. newtype Handler a - = Handler ( ReaderT (Wai.Request, Env) (Compose Maybe IO) a ) + = Handler (ReaderT (Wai.Request, Env) (Compose Maybe IO) a) deriving newtype (Functor, Applicative, Alternative) handler :: ((Wai.Request, Env) -> Maybe (IO a)) -> Handler a @@ -105,13 +102,15 @@ getById = handler $ \(req, env) -> do case req & Wai.pathInfo of ["v0", "by-id", filename] -> Just $ do Sqlite.queryNamed - @( Rec.Rec - [ "mimetype" Rec.:= Text, - "content" Rec.:= ByteString, - "size" Rec.:= Int - ] + @( T3 + "mimetype" + Text + "content" + ByteString + "size" + Int ) - (env & envData) + (env.envData) [Sqlite.sql| SELECT mimetype, @@ -129,11 +128,11 @@ getById = handler $ \(req, env) -> do [] -> Left (Http.status404, "File not found.") [res] -> Right - ( [ ("Content-Type", res & Rec.get #mimetype & textToBytesUtf8), - ("Content-Length", res & Rec.get #size & showToText & textToBytesUtf8) + ( [ ("Content-Type", res.mimetype & textToBytesUtf8), + ("Content-Length", res.size & showToText & textToBytesUtf8) ], -- TODO: should this be lazy/streamed? - res & Rec.get #content + res.content ) _more -> Left "file_references must be unique (in type and name)" & unwrapError _ -> Nothing @@ -181,7 +180,7 @@ insertById = handler $ \(req, env) -> do name <- getNameFromWordlist env let fullname = name <> extension - let conn = env & envData + let conn = env.envData Sqlite.withTransaction conn $ do Sqlite.executeNamed conn @@ -227,7 +226,7 @@ getNameFromWordlist env = do let numberOfWords = 3 :: Int Sqlite.queryNamed @(Sqlite.Only Text) - (env & envWordlist) + (env.envWordlist) [Sqlite.sql|SELECT word FROM wordlist ORDER BY RANDOM() LIMIT :words|] [":words" Sqlite.:= numberOfWords] <&> map Sqlite.fromOnly @@ -235,13 +234,14 @@ getNameFromWordlist env = -- | We can use a Rec with a named list of types to parse a returning row of sqlite!! instance - ( Rec.UnsafeRecBuild rec rec FromFieldC + ( Sqlite.FromField t1, + Sqlite.FromField t2, + Sqlite.FromField t3 ) => - Sqlite.FromRow (Rec.Rec rec) + Sqlite.FromRow (T3 l1 t1 l2 t2 l3 t3) where fromRow = do - Rec.unsafeRecBuild @rec @rec @FromFieldC (\_lbl _proxy -> Sqlite.field) - -class (Sqlite.FromField a) => FromFieldC (lbl :: Symbol) a - -instance (Sqlite.FromField a) => FromFieldC lbl a + T3 + <$> (label @l1 <$> Sqlite.field) + <*> (label @l2 <$> Sqlite.field) + <*> (label @l3 <$> Sqlite.field) |