James/HELPS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init

Browse Source
This commit is contained in:
James Eversole 2024-09-18 13:16:36 -05:00 committed by James Eversole
commit 6e2fb3b9bd
9 changed files with 358 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
HELPS.cabal Normal file
View File

@ -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

0
LICENSE Normal file
View File

9
README.md Normal file
View File

@ -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)

60
flake.lock generated Normal file
View File

@ -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
}

62
flake.nix Normal file
View File

@ -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 = ''
'';
};
};
});
}

54
src/Core.hs Normal file
View File

@ -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

58
src/Database.hs Normal file
View File

@ -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)

29
src/Handlers.hs Normal file
View File

@ -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

33
src/Main.hs Normal file
View File

@ -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