Skip to content

Instantly share code, notes, and snippets.

@divarvel
Created January 4, 2023 15:47
Show Gist options
  • Save divarvel/673ce08ff9f16d746204cae5b6141134 to your computer and use it in GitHub Desktop.
Save divarvel/673ce08ff9f16d746204cae5b6141134 to your computer and use it in GitHub Desktop.
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies#-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
module MyLib (main) where
import Relude
import Servant hiding (throwError)
import qualified Servant
import Servant.Server.Generic
import Network.Wai.Handler.Warp qualified as Warp
import Database.PostgreSQL.Transact (DBT)
import Effectful qualified as Effectful
import Effectful hiding ((:>), )
import Effectful.Dispatch.Static
import Effectful.Dispatch.Dynamic
import Effectful.Error.Static
type (::>) = (Effectful.:>)
data LinkDatabase :: Effect where
GetLink :: Text -> LinkDatabase m Text
AddLink :: Text -> Text -> LinkDatabase m ()
type instance DispatchOf LinkDatabase = 'Dynamic
getLink :: (HasCallStack, LinkDatabase ::> es) => Text -> Eff es Text
getLink shortCode = send $ GetLink shortCode
addLink :: (HasCallStack, LinkDatabase ::> es) => Text -> Text -> Eff es ()
addLink shortCode url = send $ AddLink shortCode url
data LinkError =
NoCode
| AlreadyThere
deriving stock Show
mkServerError :: LinkError -> ServerError
mkServerError = \case
NoCode -> err404
AlreadyThere -> err400
runLinkDatabase :: (Transaction ::> es, Error LinkError ::> es, IOE ::> es)
=> Eff (LinkDatabase : es) a
-> Eff es a
runLinkDatabase = interpret $ \_ -> \case
GetLink shortCode -> do
res <- q $ getUrl shortCode
case res of
Nothing -> throwError NoCode
Just url -> pure url
AddLink shortCode url -> do
_ <- q $ putUrl shortCode url
pure ()
data Routes mode = Routes
{ redirect :: mode :- Capture "shortCode" Text :> Get '[JSON] NoContent
, post :: mode :- ReqBody '[JSON] (Text, Text) :> Post '[JSON] NoContent
}
deriving stock Generic
main :: IO ()
main = do
Warp.runEnv 8000 $
genericServeT (effToHandler . handleErrors (pure . mkServerError) . runDB Pool) $ Routes
{ redirect = redirectHandler
, post = postHandler
}
redirectHandler :: ( DB ::> es, Error LinkError ::> es)
=> Text -> Eff es NoContent
redirectHandler shortCode = do
url <- runTransaction @LinkError $ runLinkDatabase $ getLink shortCode
error "todo" url
postHandler :: (DB ::> es, Error LinkError ::> es)
=> (Text, Text) -> Eff es NoContent
postHandler (shortCode, url) = do
_ <- runTransaction @LinkError $ runLinkDatabase $ addLink shortCode url
pure NoContent
getUrl :: Text -> DBT IO (Maybe Text)
getUrl = error "todo"
putUrl :: Text -> Text -> DBT IO (Maybe Text)
putUrl = error "todo"
-- effectful-servant
effToHandler :: Eff [Error ServerError, IOE] a -> Handler a
effToHandler action = do
liftIO (runEff $ runErrorNoCallStack @ServerError $ action) >>= \case
Left e -> Servant.throwError e
Right a -> pure a
handleErrors :: Error ServerError ::> es => (e -> Eff es ServerError) -> Eff (Error e : es) a -> Eff es a
handleErrors toServerError action = do
runErrorNoCallStack action >>= \case
Left e -> toServerError e >>= throwError
Right v -> pure v
-- effectful-dbt
-- - dbt helpers
data Pool = Pool
data Conn = Conn
runOnPool :: Pool -> DBT IO a -> IO a
runOnPool = error "acquire connection and run transaction on it"
data Transaction :: Effect
type instance DispatchOf Transaction = 'Static 'WithSideEffects
newtype instance StaticRep Transaction = Transaction Conn
q :: (Transaction ::> e, IOE ::> e)
=> DBT IO a -> Eff e a
q = error "lift a DBT IO into an Eff e a"
coq :: Eff '[Transaction, IOE] a -> DBT IO a
coq = error "lower a Eff e a into a DBT IO a"
runTransaction' :: DB ::> e => Eff [Transaction, IOE] a -> Eff e a
runTransaction' action = do
DB pool <- getStaticRep
unsafeEff_ $ runOnPool pool (coq action)
runTransaction :: forall e a es.
(DB ::> es, Error e ::> es) => Eff [Error e, Transaction, IOE] a
-> Eff es a
runTransaction action = error "todo"
data DB :: Effect
type instance DispatchOf DB = 'Static 'WithSideEffects
newtype instance StaticRep DB = DB Pool
runDB :: Pool -> Eff (DB : es) a -> Eff es a
runDB cfg = error "eliminate the DB effect by threading in the pool" cfg
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment