Initial File Commit

README.md

@@ -1 +1,20 @@
 # RealWorldHaskell
+
+## Requirements
+
+### Postgresql
+
+Building this code requires that you have Postgres installed on your system. If you run `stack build` and see the following error message, this indicates that you do not have Postgres:
+
+```bash
+>> stack build
+setup: The program 'pg_config' is required but it could not be found
+```
+
+On Linux, you'll want at least the following packages:
+
+```bash
+>> sudo apt install postgresql postgresql-contrib libpq-dev
+```
+
+On Windows and MacOS, you should be able to use the [downloads here](https://postgresql.org/download).

RealWorldHaskell.cabal

@@ -8,55 +8,87 @@ cabal-version: 1.12
 
 name:           RealWorldHaskell
 version:        0.1.0.0
-description:    Please see the README on GitHub at <https://github.com/githubuser/RealWorldHaskell#readme>
-homepage:       https://github.com/githubuser/RealWorldHaskell#readme
-bug-reports:    https://github.com/githubuser/RealWorldHaskell/issues
-author:         Author name here
-maintainer:     [email protected]
-copyright:      2021 Author name here
+description:    Please see the README on GitHub at <https://github.com/MondayMorningHaskell/RealWorldHaskell#readme>
+homepage:       https://github.com/MondayMorningHaskell/RealWorldHaskell#readme
+bug-reports:    https://github.com/MondayMorningHaskell/RealWorldHaskell/issues
+author:         James Bowen
+maintainer:     [email protected]
+copyright:      2021 James Bowen
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
 extra-source-files:
     README.md
-    ChangeLog.md
 
 source-repository head
   type: git
-  location: https://github.com/githubuser/RealWorldHaskell
+  location: https://github.com/MondayMorningHaskell/RealWorldHaskell
 
 library
   exposed-modules:
-      Lib
+      BasicSchema
+      BasicServer
+      Cache
+      CacheServer
+      Database
+      SchemaEsq
+      DatabaseEsq
+      ServerEsq
   other-modules:
       Paths_RealWorldHaskell
   hs-source-dirs:
       src
   build-depends:
       base >=4.7 && <5
+    , aeson
+    , bytestring
+    , esqueleto
+    , hedis
+    , monad-logger
+    , mtl
+    , persistent
+    , persistent-postgresql
+    , persistent-template
+    , servant
+    , servant-client
+    , servant-server
+    , text
+    , time
+    , transformers
+    , warp
   default-language: Haskell2010
 
-executable RealWorldHaskell-exe
-  main-is: Main.hs
-  other-modules:
-      Paths_RealWorldHaskell
-  hs-source-dirs:
-      app
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      RealWorldHaskell
-    , base >=4.7 && <5
-  default-language: Haskell2010
+executable migrate-db
+  hs-source-dirs:      app
+  main-is:             MigrateDB.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , RealWorldHaskell
+  default-language:    Haskell2010
 
-test-suite RealWorldHaskell-test
-  type: exitcode-stdio-1.0
-  main-is: Spec.hs
+executable migrate-db-esq
+  hs-source-dirs:      app
+  main-is:             MigrateDBEsq.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+                     , RealWorldHaskell
+  default-language:    Haskell2010
+
+test-suite api-tests
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
   other-modules:
-      Paths_RealWorldHaskell
-  hs-source-dirs:
-      test
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+    TestUtils
+  main-is:             APITests.hs
   build-depends:
-      RealWorldHaskell
-    , base >=4.7 && <5
-  default-language: Haskell2010
+    base
+    , hspec
+    , http-client
+    , http-client-tls
+    , monad-logger
+    , mtl
+    , servant-client
+    , persistent-postgresql
+    , RealWorldHaskell
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  default-language:    Haskell2010

app/MigrateDB.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import Database (localConnString, migrateDB)
+
+main :: IO ()
+main = migrateDB localConnString

app/MigrateDBEsq.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import DatabaseEsq (localConnString, migrateDB)
+
+main :: IO ()
+main = migrateDB localConnString

src/BasicSchema.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE UndecidableInstances       #-}
+
+module BasicSchema where
+
+import           Data.Aeson
+import           Data.Aeson.Types
+import           Database.Persist (Entity(..), Entity)
+import qualified Database.Persist.TH as PTH
+import           Data.Text (Text)
+
+PTH.share [PTH.mkPersist PTH.sqlSettings, PTH.mkMigrate "migrateAll"] [PTH.persistLowerCase|
+  User sql=users
+    name Text
+    email Text
+    age Int
+    occupation Text
+    UniqueEmail email
+    deriving Show Read
+|]
+
+instance ToJSON User where
+  toJSON user = object 
+    [ "name" .= userName user
+    , "email" .= userEmail user
+    , "age" .= userAge user
+    , "occupation" .= userOccupation user
+    ]
+
+instance FromJSON User where
+  parseJSON = withObject "User" parseUser
+
+parseUser :: Object -> Parser User
+parseUser o = do
+  uName <- o .: "name"
+  uEmail <- o .: "email"
+  uAge <- o .: "age"
+  uOccupation <- o .: "occupation"
+  return User
+    { userName = uName
+    , userEmail = uEmail
+    , userAge = uAge
+    , userOccupation = uOccupation
+    }

src/BasicServer.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module BasicServer where
+
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans.Except (throwE)
+import           Data.Int (Int64)
+import           Data.Proxy (Proxy(..))
+import           Database.Persist (Key, Entity)
+import           Database.Persist.Postgresql (ConnectionString)
+import           Network.Wai.Handler.Warp (run)
+import           Servant.API
+import           Servant.Client
+import           Servant.Server
+
+import           Database (fetchUserPG, createUserPG, localConnString)
+import           BasicSchema
+
+type UsersAPI = 
+       "users" :> Capture "userid" Int64 :> Get '[JSON] User
+  :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] Int64
+
+usersAPI :: Proxy UsersAPI
+usersAPI = Proxy :: Proxy UsersAPI
+
+fetchUsersHandler :: ConnectionString -> Int64 -> Handler User
+fetchUsersHandler connString uid = do
+  maybeUser <- liftIO $ fetchUserPG connString uid
+  case maybeUser of
+    Just user -> return user
+    Nothing -> Handler $ (throwE $ err401 { errBody = "Could not find user with that ID" })
+
+createUserHandler :: ConnectionString -> User -> Handler Int64
+createUserHandler connString user = liftIO $ createUserPG connString user
+
+usersServer :: ConnectionString -> Server UsersAPI
+usersServer connString = 
+  (fetchUsersHandler connString) :<|> 
+  (createUserHandler connString)
+
+runServer :: IO ()
+runServer = run 8000 (serve usersAPI (usersServer localConnString))

src/Cache.hs

@@ -0,0 +1,35 @@
+module Cache where
+
+import           Control.Monad (void)
+import           Data.ByteString.Char8 (pack, unpack)
+import           Data.Int (Int64)
+import           Database.Redis
+
+import           BasicSchema
+
+type RedisInfo = ConnectInfo
+
+localRedisInfo :: RedisInfo
+localRedisInfo = defaultConnectInfo
+
+runRedisAction :: RedisInfo -> Redis a -> IO a
+runRedisAction redisInfo action = do
+  connection <- connect redisInfo
+  runRedis connection action
+
+cacheUser :: RedisInfo -> Int64 -> User -> IO ()
+cacheUser redisInfo uid user = runRedisAction redisInfo $ void $ setex (pack . show $ uid) 3600 (pack . show $ user)
+
+fetchUserRedis :: RedisInfo -> Int64 -> IO (Maybe User)
+fetchUserRedis redisInfo uid = runRedisAction redisInfo $ do
+  result <- get (pack . show $ uid)
+  case result of
+    Right (Just userString) -> return $ Just (read . unpack $ userString)
+    _ -> return Nothing
+
+deleteUserCache :: RedisInfo -> Int64 -> IO ()
+deleteUserCache redisInfo uid = do
+  connection <- connect redisInfo
+  runRedis connection $ do
+    _ <- del [pack . show $ uid]
+    return ()

src/CacheServer.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module CacheServer where
+
+import           Control.Monad.IO.Class (liftIO)
+import           Control.Monad.Trans.Except (throwE)
+import           Data.Int (Int64)
+import           Data.Proxy (Proxy(..))
+import           Database.Persist (Key, Entity)
+import           Network.Wai.Handler.Warp (run)
+import           Servant.API
+import           Servant.Client
+import           Servant.Server
+
+import           BasicSchema
+import           Cache
+import           Database
+
+type UsersAPI =
+       "users" :> Capture "userid" Int64 :> Get '[JSON] User
+  :<|> "users" :> ReqBody '[JSON] User :> Post '[JSON] Int64
+
+usersAPI :: Proxy UsersAPI
+usersAPI = Proxy :: Proxy UsersAPI
+
+fetchUsersHandler :: PGInfo -> RedisInfo -> Int64 -> Handler User
+fetchUsersHandler pgInfo redisInfo uid = do
+  maybeCachedUser <- liftIO $ fetchUserRedis redisInfo uid
+  case maybeCachedUser of
+    Just user -> return user
+    Nothing -> do
+      maybeUser <- liftIO $ fetchUserPG pgInfo uid
+      case maybeUser of
+        Just user -> liftIO (cacheUser redisInfo uid user) >> return user
+        Nothing -> Handler $ (throwE $ err401 { errBody = "Could not find user with that ID" })
+
+createUserHandler :: PGInfo -> User -> Handler Int64
+createUserHandler pgInfo user = liftIO $ createUserPG pgInfo user
+
+usersServer :: PGInfo -> RedisInfo -> Server UsersAPI
+usersServer pgInfo redisInfo =
+  (fetchUsersHandler pgInfo redisInfo) :<|>
+  (createUserHandler pgInfo)
+
+runServer :: IO ()
+runServer = run 8000 (serve usersAPI (usersServer localConnString localRedisInfo))
+
+fetchUserClient :: Int64 -> ClientM User
+createUserClient :: User -> ClientM Int64
+(fetchUserClient :<|> createUserClient) = client (Proxy :: Proxy UsersAPI)