init

HELPS.cabal

@@ -0,0 +1,53 @@
+cabal-version: 1.12
+
+name:           HELPS
+version:        0.0.1
+description:    Haskell, Effectful, Lucid, PostgreSQL, Servant
+author:         James Eversole
+maintainer:     james@eversole.co
+copyright:      James Eversole
+license:        ISC
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README
+
+executable Main
+  main-is: Main.hs
+  hs-source-dirs:
+      src
+  default-extensions:
+      BlockArguments
+      ConstraintKinds
+      DataKinds
+      DeriveAnyClass
+      DeriveGeneric
+      DerivingStrategies
+      FlexibleContexts
+      FlexibleInstances
+      GeneralizedNewtypeDeriving
+      LambdaCase
+      OverloadedRecordDot
+      OverloadedStrings
+      ScopedTypeVariables
+      StrictData
+      TypeFamilies
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
+  build-depends:
+    base
+    , aeson
+    , bytestring
+    , effectful
+    , exceptions
+    , lucid
+    , mtl
+    , postgresql-simple
+    , servant-server
+    , text
+    , utf8-string
+    , warp
+  other-modules:
+    Core
+    Database
+    Handlers
+  default-language: GHC2021

README.md

@@ -0,0 +1,9 @@
+# servant-effectful-template
+
+A nix starting template for web projects utilizing
+
+- [Haskell](https://wiki.haskell.org/Haskell)
+- [Effectful](https://github.com/haskell-effectful/effectful)
+- [Lucid](https://github.com/chrisdone/lucid)
+- [PostgreSQL](https://www.postgresql.org/)
+- [Servant](https://github.com/haskell-servant/servant)

flake.lock

@@ -0,0 +1,60 @@
+{
+  "nodes": {
+    "flake-utils": {
+      "inputs": {
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1726560853,
+        "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1728764407,
+        "narHash": "sha256-J4kaIxwjrGVQkLA6njCFH09xj2oCf/VWFircIy7b65k=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "4ada35702a7146e1df24f8d6987a1d7c1a5a4707",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "flake-utils": "flake-utils",
+        "nixpkgs": "nixpkgs"
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,62 @@
+{
+  description = "HELPS";
+
+  inputs = {
+    nixpkgs.url = "github:NixOS/nixpkgs";
+    flake-utils.url = "github:numtide/flake-utils";
+  };
+
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
+      let
+        pkgs              = nixpkgs.legacyPackages.${system};
+        packageName       = "HELPS";
+        containerPackageName = "${packageName}-container";
+
+        haskellPackages = pkgs.haskellPackages;
+
+        enableSharedExecutables = false;
+        enableSharedLibraries = false;
+
+        HELPS = pkgs.haskell.lib.justStaticExecutables self.packages.${system}.default;
+      in {
+
+        packages.${packageName} =
+          haskellPackages.callCabal2nix packageName self rec {};
+
+        packages.default = self.packages.${system}.${packageName};
+        defaultPackage = self.packages.${system}.default;
+
+        devShells.default = pkgs.mkShell {
+          buildInputs = with pkgs; [
+            ghcid
+            cabal-install
+            ghc
+          ];
+          inputsFrom = builtins.attrValues self.packages.${system};
+        };
+        devShell = self.devShells.${system}.default;
+
+        packages.${containerPackageName} = pkgs.dockerTools.buildImage {
+          name = "HELPS";
+
+          copyToRoot = pkgs.buildEnv {
+            name = "image-root";
+            paths = [ HELPS ];
+            pathsToLink = [ "/bin" ];
+          };
+          tag = "latest";
+          config = {
+            Cmd = [
+              "/bin/Purr"
+            ];
+            WorkingDir = "/app";
+            ExposedPorts = {
+              "3000/tcp" = {};
+            };
+            extraCommands = ''
+            '';
+          };
+        };
+      });
+}

src/Core.hs

@@ -0,0 +1,54 @@
+module Core where
+
+import Control.Exception                  (IOException)
+import Data.Aeson                         (FromJSON, ToJSON)
+import qualified Data.Text                as T
+import Database.PostgreSQL.Simple         (Query)
+import Database.PostgreSQL.Simple.FromRow (FromRow, field, fromRow)
+import Database.PostgreSQL.Simple.ToRow   (ToRow, toRow)
+import Database.PostgreSQL.Simple.ToField (ToField)
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Error.Static             (Error)
+import Effectful.FileSystem
+import GHC.Generics                       (Generic)
+import Servant hiding                     ((:>))
+import qualified Servant                  as S
+
+-- Core data
+data User = User { userId :: Int, userName :: String}
+  deriving (Show, Generic)
+
+instance FromRow User where
+    fromRow = User <$> field <*> field
+instance ToRow User where
+    toRow (User uid name) = toRow (uid, name)
+
+instance ToJSON User
+instance FromJSON User
+
+-- Effects
+type AppEff = Eff '[Database, FileSystem, Error ServerError, IOE]
+
+data Database :: Effect where
+  DatabaseRead  :: (Query, Int)    -> Database (Eff es) (Maybe User)
+  DatabaseWrite :: (Query, String) -> Database (Eff es) ()
+
+type instance DispatchOf Database = 'Dynamic
+
+databaseRead  :: (Database :> es, Error ServerError :> es) => (Query, Int) -> Eff es (Maybe User)
+databaseRead  = send . DatabaseRead
+
+databaseWrite :: (Database :> es, Error ServerError :> es) => (Query, String) -> Eff es ()
+databaseWrite = send . DatabaseWrite
+
+-- Routes
+type Root     = Get '[PlainText] T.Text
+type UserList = "user" S.:> Get '[JSON] [User]
+type UserGet  = "user" S.:> Capture "userId"     Int    S.:> Get  '[JSON] User
+type UserPost = "user" S.:> ReqBody '[PlainText] String S.:> PostCreated '[PlainText] NoContent
+
+type API = Root
+      :<|> UserList
+      :<|> UserGet
+      :<|> UserPost

src/Database.hs

@@ -0,0 +1,58 @@
+module Database where
+
+import Core
+
+import Control.Exception          (IOException)
+import Control.Monad.Catch        (catch)
+import Data.Aeson                 (ToJSON)
+import Data.ByteString.Lazy.UTF8  (fromString)
+import Data.Maybe                 (listToMaybe)
+import Database.PostgreSQL.Simple 
+import Effectful
+import Effectful.Dispatch.Dynamic
+import Effectful.Error.Static     (Error, HasCallStack, catchError, runErrorNoCallStack, throwError)
+import Servant hiding             ((:>), throwError)
+
+runDatabaseDebug :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseDebug = interpret $ \_ -> \case
+  DatabaseRead  (statement, values)  -> adapt $ read  statement values
+  DatabaseWrite (statement, values)  -> adapt $ write statement values
+  where
+    read  _ values = 
+      putStrLn "We just mocked a READ database operation" >>= \_ -> pure $ 
+        Just (User values "Mock User")
+    write _ values = 
+      putStrLn $ "We just mocked a WRITE database operation with a user named " 
+        ++ values
+
+runDatabaseIO :: (IOE :> es, Error ServerError :> es) => Eff (Database : es) a -> Eff es a
+runDatabaseIO = interpret $ \_ -> \case
+  DatabaseRead  (statement, values) -> adapt $ read  statement values
+  DatabaseWrite (statement, values) -> adapt $ write statement values
+  where
+    read  :: Query -> Int -> IO (Maybe User)
+    read statement values  = do
+      conn <- openConn
+      user <- query conn statement (Only values)
+      pure  $ listToMaybe user
+    write :: Query -> String -> IO ()
+    write statement values = do
+      conn <- openConn
+      execute conn statement (Only values)
+      putStrLn $ "Wrote user to database using statement:\n" ++ show statement
+    openConn = connectPostgreSQL "host=localhost port=5432 dbname=demo connect_timeout=10"
+
+adapt :: (IOE :> es, Error ServerError :> es) => IO a -> Eff es a
+adapt m = liftIO m `catch` \(e::IOException) ->
+  throwError $ ServerError
+    { errHTTPCode     = 500
+    , errReasonPhrase = "Internal Database Error"
+    , errBody         = fromString $ show e
+    , errHeaders      = []
+    }
+
+queryUser :: Int -> (Query, Int)
+queryUser userId = ("SELECT id, name FROM users WHERE id = ?;", userId)
+
+writeUser :: String -> (Query, String)
+writeUser name   = ("INSERT INTO users (name) VALUES (?);", name)

src/Handlers.hs

@@ -0,0 +1,29 @@
+module Handlers where
+
+import Core
+import Database
+
+import qualified Data.ByteString.Char8    as C
+import Data.List
+import qualified Data.Text                as T
+import Effectful
+import Effectful.Error.Static             (Error, throwError)
+import Effectful.FileSystem
+import Effectful.FileSystem.IO.ByteString as EBS
+import Servant hiding                     ((:>), throwError)
+import qualified Servant                  as S
+
+rootHandler :: (Error ServerError :> es) => Eff es T.Text
+rootHandler = return "Hello, World!"
+
+userListHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Eff es [User]
+userListHandler = mapM userGetHandler [1, 2, 3]
+
+userGetHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => Int -> Eff es User
+userGetHandler userId = databaseRead (queryUser userId) >>= \mUser -> 
+  case mUser of
+    Just a  -> pure a
+    Nothing -> pure (User 0 "No user found")
+
+userPostHandler :: (Database :> es, Error ServerError :> es, FileSystem :> es) => String -> Eff es NoContent
+userPostHandler name = databaseWrite (writeUser name) >>= \_ -> return NoContent

src/Main.hs

@@ -0,0 +1,33 @@
+module Main (main) where
+
+import Core
+import Database
+import Handlers
+
+import Control.Monad.Except     (ExceptT (ExceptT))
+import Data.List
+import Effectful
+import Effectful.Error.Static   (Error, runError, runErrorNoCallStack, throwError)
+import Effectful.FileSystem
+import Network.Wai.Handler.Warp (run)
+import Servant hiding           ((:>), throwError)
+import qualified Servant        as S
+
+main :: IO ()
+main = run port $ serve proxy app
+
+app :: Server API
+app = α $ rootHandler
+     :<|> userListHandler
+     :<|> userGetHandler
+     :<|> userPostHandler
+
+α :: ServerT API AppEff -> ServerT API Handler
+α = hoistServer proxy $ Handler . ExceptT .
+  runEff . runErrorNoCallStack . runFileSystem . runDatabaseIO
+
+port :: Int
+port = 8080
+
+proxy :: Proxy API
+proxy = Proxy