gists/hs-literest/literest.hs

#!/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