haskell literest

.gitignore

@@ -2,3 +2,6 @@ c-moving-ball/raylib.h
 c-moving-ball/wasm.sh
 c-moving-ball/wasm
 c-moving-ball/game
+
+hs-literest/literest.db
+hs-literest/build/

hs-literest/literest.hs

@@ -0,0 +1,268 @@
+#!/usr/bin/env cabal
+{- cabal:
+ghc-options: -Wall
+build-depends:
+  base,
+  text,
+  sqlite-easy,
+  twain,
+  warp,
+  bytestring,
+  wai-extra,
+-}
+
+{-
+
+Gist accompanying https://alloca.space/blog/haskell-lang.html
+
+Build and Run
+-------------
+
+1. Install GHC and Cabal using https://haskell.org/ghcup
+2. Add execution permissions `chmod +x literest`
+3. Run with `./literest.hs` (wait for it to download packages and compile, and for the listening message to display)
+
+Setup Database
+--------------
+
+Create tables in literest using sqlite3, for example:
+
+```
+create table user(id int, name text, email text);
+insert into user values (1, 'haskell', 'haskell@haskell.org');
+insert into user values (2, 'Dean', 'dean@supernatural.com');
+insert into user values (3, 'Sammy', 'sam@supernatural.com');
+```
+
+Run a query
+-----------
+
+Use `curl` to run a query and `jq` to format the results
+
+```
+curl "http://localhost:8888/user?project=name,email&select=or(id.eq.2,name.eq.Sammy)" | jq
+```
+
+-}
+
+{-# language GHC2024, OverloadedStrings #-}
+
+import Data.Char (isAlphaNum)
+import Data.String
+import Data.Text qualified as T
+import Data.ByteString.Lazy qualified as BL
+import Data.Text.Encoding qualified as T
+
+import Database.Sqlite.Easy qualified as Sqlite
+
+import Web.Twain qualified as Twain
+import Network.Wai.Handler.Warp qualified as Warp
+import qualified Network.Wai.Middleware.RequestLogger as Logger
+import Control.Monad.IO.Class (liftIO)
+
+main :: IO ()
+main = do
+  pool <- Sqlite.createSqlitePool "./literest.db"
+  putStrLn "Server running at http://localhost:8888 (ctrl-c to quit)"
+  Warp.run 8888 (Logger.logStdoutDev $ app pool)
+
+-----------------------------------
+-- * Server
+
+app :: Sqlite.Pool Sqlite.Database -> Twain.Application
+app dbpool =
+    (Twain.get "/:rootField" (handleRootField dbpool))
+    (Twain.notFound (Twain.send (Twain.text "404 Not Found.")))
+
+handleRootField :: Sqlite.Pool Sqlite.Database -> Twain.ResponderM a
+handleRootField dbpool = do
+  rootField <- Twain.param "rootField"
+  projection <- parseProjection <$> Twain.paramMaybe "project"
+  selection <- parseSelection =<< Twain.paramMaybe "select"
+
+  let
+    query = Query (Name rootField) projection selection
+    sql = compile query
+
+  liftIO (print sql)
+
+  res <- liftIO (runSql dbpool sql)
+
+  case res of
+    [[Sqlite.SQLText result]] ->
+      Twain.send $
+        Twain.raw
+          Twain.ok200
+          [(Twain.hContentType, "application/json; charset=utf-8")]
+          (BL.fromStrict (T.encodeUtf8 result))
+    _ ->
+      error "Internal error."
+
+------------------------------------------
+-- * Model
+-- We use types do specify our model
+
+-- | A Name of a table or a column
+newtype Name = Name T.Text
+    deriving Show
+
+-- | A definition of a query
+data Query
+  = Query
+    { rootField :: Name
+    , projection :: [Name]
+    , selection :: BooleanExpression
+    }
+    deriving Show
+
+-- | A boolean expression for selection
+data BooleanExpression
+  = Eq Name Value
+  | And [BooleanExpression]
+  | Or [BooleanExpression]
+  | Not BooleanExpression
+    deriving Show
+
+-- | A scalar value
+data Value
+  = Text T.Text
+    deriving Show
+
+type Error = String
+
+------------------------------------------
+-- * SQL
+-- data type for parameterised sql strings combined with values
+
+data SQL = SQL String [Value]
+  deriving Show
+
+instance Semigroup SQL where
+  (<>) (SQL str1 vals1) (SQL str2 vals2) =
+    SQL (str1 <> str2) (vals1 <> vals2)
+
+instance Monoid SQL where
+  mempty = SQL "" []
+
+instance IsString SQL where
+  fromString str = SQL str []
+
+(<+>) :: SQL -> SQL -> SQL
+(<+>) s1 s2 = s1 <> " " <> s2
+
+unwordsSQL :: [SQL] -> SQL
+unwordsSQL = intercalate " "
+
+intercalate :: Monoid m => m -> [m] -> m
+intercalate divider = \case
+  x : y : xs -> x <> divider <> intercalate divider (y:xs)
+  xs -> mconcat xs
+
+------------------------------------------
+-- * Compiler
+
+-- | Compile a graphql query to SQL
+compile :: Query -> SQL
+compile query =
+  case query of
+    Query { rootField, projection, selection } ->
+      unwordsSQL
+        [ "SELECT"
+        , "json_group_array(json_object(" <>
+          intercalate ", " (map compileNameProj projection)
+          <> "))"
+        , "FROM"
+        , compileName rootField
+        , "WHERE"
+        , compileBoolExpr selection
+        ]
+
+-- | Convert a boolean expression to a SQL fragment
+compileBoolExpr :: BooleanExpression -> SQL
+compileBoolExpr = \case
+  Eq field value ->
+    compileName field <+> "=" <+> compileValue value
+  And [] ->
+    "true"
+  And exprs ->
+    "(" <> intercalate " AND " (map compileBoolExpr exprs) <> ")"
+  Or [] ->
+    "false"
+  Or exprs ->
+    "(" <> intercalate " OR " (map compileBoolExpr exprs) <> ")"
+  Not expr ->
+    "NOT" <+> "(" <> compileBoolExpr expr <> ")"
+
+-- | Convert a value to a SQL fragment
+compileValue :: Value -> SQL
+compileValue value = SQL "?" [value]
+
+-- | Convert a field name
+compileName :: Name -> SQL
+compileName (Name field)
+  | not (T.all isAlphaNum field) =
+    error $ "Field '" <> T.unpack field <> "' contains non alpha numeric characters"
+  | otherwise = SQL (T.unpack field) []
+
+-- | Convert a field name as a key - value mapping for json_object
+compileNameProj :: Name -> SQL
+compileNameProj field =
+  "'" <> compileName field <> "', " <> compileName field
+
+-----------------------------------
+-- * Request Parsing
+
+parseProjection :: Maybe T.Text -> [Name]
+parseProjection =
+  maybe [] id . fmap (map Name . T.split (',' ==))
+
+parseSelection =
+  maybe (pure $ And []) (either error pure . parseBooleanExpression)
+
+parseBooleanExpression :: T.Text -> Either Error BooleanExpression
+parseBooleanExpression text =
+  case T.break (`elem` ['.', '(']) text of
+    (_, "") -> Left "Unsupported format."
+    (field, value)
+      | field == "not" -> do
+        values <- parseComplex value
+        case values of
+          [v] -> Right (Not v)
+          _ -> Left "Not accepts exactly one boolean expression"
+
+      | field == "and" ->
+        And <$> parseComplex value
+
+      | field == "or" ->
+        Or <$> parseComplex value
+
+      | otherwise ->
+        parseField field value
+
+parseComplex :: T.Text -> Either Error [BooleanExpression]
+parseComplex text =
+  case T.uncons text of
+    Just ('(', rest) ->
+      case T.unsnoc rest of
+        Just (fields, ')') ->
+          traverse parseBooleanExpression (T.split (',' ==) fields)
+        _ -> Left "Unsupported Format"
+    _ -> Left "Unsupported Format"
+
+parseField :: T.Text -> T.Text -> Either Error BooleanExpression
+parseField field text =
+  case T.split ('.' ==) text of
+    ["", "eq", v] -> Right (Eq (Name field) (Text v))
+    _ -> Left "Unsupported operation or format."
+
+-----------------------------------
+-- * Database
+
+runSql :: Sqlite.Pool Sqlite.Database -> SQL -> IO [[Sqlite.SQLData]]
+runSql pool (SQL sql values) = do
+  Sqlite.withPool pool $
+    Sqlite.runWith (fromString sql) (fmap fromValue values)
+
+fromValue :: Value -> Sqlite.SQLData
+fromValue = \case
+  Text s -> Sqlite.SQLText s