MyLib.hs

{-# 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