diff --git a/.gitignore b/.gitignore index 9c3d975..20524ef 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,6 @@ WD bin/ +data /result /Dockerfile /docker-stack.yml diff --git a/HELPS.cabal b/HELPS.cabal index 0ece241..90a2f1e 100644 --- a/HELPS.cabal +++ b/HELPS.cabal @@ -25,10 +25,12 @@ common global , mtl , postgresql-simple , resource-pool + , servant-lucid , servant-server , text , time , utf8-string + , wai-middleware-static , warp default-extensions: BlockArguments @@ -58,6 +60,7 @@ executable Main Handlers Logger Routes + Views build-depends: HELPS @@ -65,4 +68,4 @@ library import: global hs-source-dirs: src - exposed-modules: Core, Database, Handlers, Logger, Routes + exposed-modules: Core, Database, Handlers, Logger, Routes, Views, Main diff --git a/src/Core.hs b/src/Core.hs index c69025d..b38873a 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -15,6 +15,7 @@ import Effectful.Error.Static (Error, throwError) import Effectful.Reader.Static (Reader) import GHC.Generics (Generic) import Servant hiding ((:>), throwError) +import Servant.HTML.Lucid -- -- Core data types diff --git a/src/Database.hs b/src/Database.hs index bceefe2..500c70b 100644 --- a/src/Database.hs +++ b/src/Database.hs @@ -4,6 +4,7 @@ import Core import Control.Exception (IOException) import Data.Aeson (ToJSON) +import Data.ByteString (ByteString) import Data.Maybe (listToMaybe) import Data.Pool import qualified Data.Text as T @@ -91,9 +92,9 @@ runDatabaseDebug = interpret $ \_ -> \case ++ "\nValues:\n" ++ show values -createConnectionPool :: IO (Pool Connection) -createConnectionPool = newPool $ defaultPoolConfig - (connectPostgreSQL "host=localhost dbname=demo") +createConnectionPool :: ByteString -> IO (Pool Connection) +createConnectionPool connectString = newPool $ defaultPoolConfig + (connectPostgreSQL connectString) close 60 10 diff --git a/src/Handlers.hs b/src/Handlers.hs index 0d2fd1c..e583ee0 100644 --- a/src/Handlers.hs +++ b/src/Handlers.hs @@ -3,26 +3,35 @@ module Handlers where import Core import Database import Logger +import Views as V 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 Lucid (Html) import Servant hiding ((:>), throwError) -import qualified Servant as S +import Servant.HTML.Lucid +-- Type synonym for common CRUD constraints like interacting with a database, +-- logging, and the possibility to throw an error. type CRUD es = ( Database :> es, Logger :> es, Error ServerError :> es ) -rootHandler :: (Logger :> es, Error ServerError :> es) - => Eff es T.Text -rootHandler = (writeLog Info "Hit the root!") >>= \_ -> - return "Hello, World!" +-- Remember to drop effect constraints you don't need! +rootHandler :: (Logger :> es, Error ServerError :> es) + => Eff es (Html ()) +rootHandler = (writeLog Info "Hit the root!") + >>= \_ -> return V.root userListHandler :: CRUD es - => Eff es [User] -userListHandler = (writeLog Info "Selected all users!") >>= \_ -> - databaseRead_ "SELECT id, name FROM users" + => Eff es (Html ()) +userListHandler = do + writeLog Info "Selected all users!" + users <- databaseRead_ "SELECT id, name FROM users" + return $ V.baseDoc $ case users of + [] -> warning "No users found" + _ -> foldMap userHtml users userGetHandler :: CRUD es => UserId -> Eff es User diff --git a/src/Main.hs b/src/Main.hs index 7bf6cdb..67462c8 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,24 +6,25 @@ import Handlers import Logger import Routes -import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Except (ExceptT (ExceptT)) import Data.List import Effectful -import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) +import Effectful.Error.Static (Error, runErrorNoCallStack, throwError) import Effectful.Reader.Static -import Network.Wai.Handler.Warp (run) -import Servant hiding ((:>), throwError) -import qualified Servant as S +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Static ((>->), staticPolicy, noDots, addBase) +import Servant hiding ((:>), throwError) +import qualified Servant as S -- -- Application -- main :: IO () main = do - pool <- createConnectionPool + pool <- createConnectionPool "host=localhost dbname=demo" let env = AppEnv { pool = pool } runAppEff env $ databaseInit - run port . serve proxy $ app env + run port . middleware . serve proxy $ app env app :: AppEnv -> Server AppAPI app env = hoistServer proxy (Handler . ExceptT . runAppEff env) handlers @@ -35,6 +36,9 @@ handlers = rootHandler :<|> userPostHandler :<|> userDeleteHandler +middleware :: Application -> Application +middleware = staticPolicy (noDots >-> addBase "data/assets/public") + runAppEff :: AppEnv -> AppEff a -> IO (Either ServerError a) runAppEff env = runEff . runErrorNoCallStack diff --git a/src/Routes.hs b/src/Routes.hs index d1b5a27..3e8e7c0 100644 --- a/src/Routes.hs +++ b/src/Routes.hs @@ -3,15 +3,17 @@ module Routes where import Core import qualified Data.Text as T +import Lucid (Html) import Servant +import Servant.HTML.Lucid -- -- Routes -- -type Root = Get '[PlainText] T.Text +type Root = Get '[HTML] (Html ()) type UserList = "user" - :> Get '[JSON] [User] + :> Get '[HTML] (Html ()) type UserGet = "user" :> Capture "userId" UserId diff --git a/src/Views.hs b/src/Views.hs new file mode 100644 index 0000000..cd3ebb0 --- /dev/null +++ b/src/Views.hs @@ -0,0 +1,34 @@ +module Views where + +import Core + +import Data.Text +import Data.String (fromString) +import Effectful +import Lucid + +baseDoc :: Html () -> Html () +baseDoc a = doctypehtml_ $ do + head_ $ do + meta_ [ name_ "viewport", content_ "width=device-width, initial-scale=1.0" ] + title_ "HELPS Template!" + link_ [rel_ "stylesheet", type_ "text/css", href_ "/style.css"] + body_ $ do + main_ [ class_ "container" ] a + +root :: Html () +root = baseDoc $ do + h1_ "Welcome to HELPS!" + p_ "Haskell, Effectful, Lucid, PostgreSQL, Servant" + p_ "You can get started by reviewing the README.md for directions on using \ + \ this template for your own projects." + +userHtml :: User -> Html () +userHtml user = div_ [] $ do + ul_ $ do + li_ $ do + "Username: " >> toHtml (show $ userName user) + ul_ $ li_ $ "User ID: " >> toHtml (show $ userId user) + +warning :: String -> Html () +warning s = p_ [class_ "warning"] (toHtml s)