newsletter-0: tools/Server.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Main where

import           Control.Lens
import           Control.Monad.Except
import           Control.Monad.Reader
import           Data.Machine
import           Data.Maybe
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.Lazy.IO as TLIO
import           Network.Mail.Newsletter.Class
import           Network.Mail.Newsletter.Web
import           Network.Mail.Mime
import           Network.URI
import qualified Network.Wai.Handler.Warp as Warp
import           Servant
import           Text.Printf
import qualified Web.ClientSession as CS

newtype NewsM a
 = NewsM { runNewsT :: ReaderT NewsData Handler a }
 deriving (Functor, Applicative, Monad, MonadReader NewsData, MonadIO, MonadError ServantErr)

data NewsData
 = NewsData
   { _ndTemplates        :: NlTemplates NewsM
   , _ndClientSessKey    :: CS.Key
   , _ndPort             :: Int
   , _ndInMemDedup       :: InMemoryDedup
   , _ndTimeouts         :: NewsletterTimeouts
   , _ndAllowedOrigins   :: [URIAuth]
   }

makeLenses ''NewsData

instance HasAllowedOrigins NewsData where
  allowedOrigins = ndAllowedOrigins

instance HasNewsletterTimeouts NewsData where
  newsletterTimeouts = ndTimeouts

instance HasNlTemplates NewsData NewsM where
  nlTemplates = ndTemplates

instance HasClientSessionKey NewsData where
  clientSessionKey = ndClientSessKey

instance DedupSubscriptions NewsM where
  recentlySubscribed = genericInMemRecentlySubscribed

instance HasApiRoot NewsM where
  type ApiRoot NewsM = NewsletterAPI
  apiRoot = pure newsletterApi
  apiBase = (fromJust . parseAbsoluteURI . ((<>) "http://127.0.0.1:8080/") . show) <$> view ndPort

instance HasInMemoryDedup NewsData where
  inMemoryDedup = ndInMemDedup

instance Newsletter NewsM where
  subscribe = autoM $ \sub ->
              liftIO $ printf "Subscribing %s\n" (show sub)
  unsubscribe = autoM $ \unsub ->
              liftIO $ printf "Unsubscribing %s\n" (show unsub)
  subscribers = source []
  sendEmail mkEmail = liftIO $
    renderMail' (mkEmail "newsletter@example.org") >>= TLIO.putStrLn . TLE.decodeUtf8
  sendSubscribe _ mkEmail = liftIO $
    renderMail' (mkEmail "newsletter@example.org") >>= TLIO.putStrLn . TLE.decodeUtf8

nt :: NewsData -> NewsM a -> Handler a
nt s x = runReaderT (runNewsT x) s

app :: NewsData -> Application
app s = serve newsletterApi $ hoistServer newsletterApi (nt s) serveNewsletter

main :: IO ()
main = do
  (_, k) <- CS.randomKey
  let port = 8080
  p <- newInMemDedup (fromInteger $ 24*60*60)
  let s = NewsData defTemplates k port p (NewsletterTimeouts 5 1) [URIAuth "" "127.0.0.1" (show port)]
  Warp.run port $ app $ s