newsletter (empty) → 0
raw patch · 12 files changed
+771/−0 lines, 12 filesdep +aesondep +basedep +blaze-htmlsetup-changed
Dependencies added: aeson, base, blaze-html, bytestring, clientsession, email-validate, http-api-data, lens, machines, mime-mail, mtl, network-uri, newsletter, psqueues, random, servant, servant-blaze, servant-server, stm, text, time, unordered-containers, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- newsletter.cabal +67/−0
- src/Network/Mail/Newsletter.hs +9/−0
- src/Network/Mail/Newsletter/Class.hs +21/−0
- src/Network/Mail/Newsletter/Web.hs +14/−0
- src/Network/Mail/Newsletter/Web/API.hs +183/−0
- src/Network/Mail/Newsletter/Web/Dedup/InMem.hs +40/−0
- src/Network/Mail/Newsletter/Web/Handlers.hs +141/−0
- src/Network/Mail/Newsletter/Web/Templates.hs +173/−0
- tools/Server.hs +86/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for newsletter++## 0 -- 2019-05-06++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, davean++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of davean nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ newsletter.cabal view
@@ -0,0 +1,67 @@+cabal-version: 2.2++name: newsletter+version: 0+synopsis: A basic newsletter implimentation, using various backends.+description:+ This package impliments a webserver that manages mailing list subscripts and provides+ tools to send to said list. Mail sending services are provided by backends like+ <newsletter-mailgun https://hackage.haskell.org/package/newsletter-mailgun>.+homepage: https://oss.xkcd.com/+license: BSD-3-Clause+license-file: LICENSE+author: davean+maintainer: oss@xkcd.com+copyright: Copyright (C) 2019 davean+category: Email, Web+extra-source-files: CHANGELOG.md++source-repository head+ type: git+ location: https://code.xkrd.net/haskell/newsletter.git++common deps+ build-depends:+ aeson ^>= 1.4+ , base ^>= 4.12.0.0+ , blaze-html ^>= 0.9+ , bytestring ^>= 0.10+ , clientsession ^>= 0.9+ , email-validate ^>= 2.3+ , http-api-data ^>= 0.4+ , lens ^>= 4.17+ , machines ^>= 0.6+ , mime-mail ^>= 0.5+ , mtl ^>= 2.2+ , network-uri ^>= 2.6+ , psqueues ^>= 0.2+ , random ^>= 1.1+ , servant ^>= 0.15+ , servant-blaze ^>= 0.9+ , servant-server ^>= 0.15+ , stm ^>= 2.5+ , text ^>= 1.2+ , time ^>= 1.8+ , unordered-containers ^>= 0.2++library+ import: deps+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ Network.Mail.Newsletter+ Network.Mail.Newsletter.Class+ Network.Mail.Newsletter.Web+ Network.Mail.Newsletter.Web.API+ Network.Mail.Newsletter.Web.Dedup.InMem+ Network.Mail.Newsletter.Web.Handlers+ Network.Mail.Newsletter.Web.Templates++executable newsletter-server+ import: deps+ main-is: Server.hs+ hs-source-dirs: tools+ default-language: Haskell2010+ build-depends:+ , newsletter+ , warp ^>= 3.2
+ src/Network/Mail/Newsletter.hs view
@@ -0,0 +1,9 @@+module Network.Mail.Newsletter+ ( module Network.Mail.Newsletter.Class+ , module Network.Mail.Newsletter.Web+ , module Network.Mail.Newsletter.Web.API+ ) where++import Network.Mail.Newsletter.Class+import Network.Mail.Newsletter.Web+import Network.Mail.Newsletter.Web.API
+ src/Network/Mail/Newsletter/Class.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Network.Mail.Newsletter.Class where++import qualified Data.Aeson as JS+import Data.Machine+import Network.Mail.Mime++class Newsletter p where+ -- | Adds users with specific data to the Newsletter recipient list.+ subscribe :: ProcessT p (Address, JS.Value) ()+ -- | Removes users from the Newsletter recipient list.+ unsubscribe :: ProcessT p Address ()+ -- | Gets a list of subscribers and all their associated data.+ subscribers :: SourceT p (Address, JS.Value)+ -- | Send an email to the mailing list.+ -- Takes as From Address for correctness.+ sendEmail :: (Address -> Mail) -> p ()+ -- | Sends a subscription email to just the person signing up.+ -- Takes the From Address to create the mail for correctness.+ sendSubscribe :: Address -> (Address -> Mail) -> p ()
+ src/Network/Mail/Newsletter/Web.hs view
@@ -0,0 +1,14 @@+module Network.Mail.Newsletter.Web+ ( HasApiRoot(..), DedupSubscriptions(..), HasAllowedOrigins(..), HasClientSessionKey(..)+ , NewsletterTimeouts(..), HasNewsletterTimeouts(..)+ , NewsletterAPI, newsletterApi+ , HasNlTemplates(..), NlTemplates(..), defTemplates+ , serveNewsletter+ , module Network.Mail.Newsletter.Web.Dedup.InMem+ ) where+++import Network.Mail.Newsletter.Web.API+import Network.Mail.Newsletter.Web.Handlers+import Network.Mail.Newsletter.Web.Templates+import Network.Mail.Newsletter.Web.Dedup.InMem
+ src/Network/Mail/Newsletter/Web/API.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Network.Mail.Newsletter.Web.API+ ( HasApiRoot(..)+ , DedupSubscriptions(..)+ , HasClientSessionKey(..)+ , HasAllowedOrigins(..)+ , NewsletterTimeouts(..)+ , HasNewsletterTimeouts(..)+ , RefPolicy(..)+ , NewsletterAPI, newsletterApi+ , genUnsubLink+ , genSubConfirmLink+ , NewsletterUnsub, NewsletterUnsubGet, NewsletterUnsubPost+ , NewsletterSub, NewsletterSubGet, NewsletterSubPost+ , NewsletterSubConfirm, NewsletterSubConfirmGet, NewsletterSubConfirmPost+ , decodeCS+ , SignupReq(..)+ , encSignup, decSignup+ ) where++import Control.Lens+import Control.Monad.Trans+import Control.Monad.Reader+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time+import Data.Proxy (Proxy(..))+import Network.Mail.Mime (Address(..))+import Network.URI+import Servant+import Servant.HTML.Blaze+import Text.Blaze.Html+import Text.Printf+import qualified Web.ClientSession as CS+import Web.FormUrlEncoded++data RefPolicy+ = NoRef+ | SameOrigin+ | StrictOrigin+ | StrictOriginCross++instance Show RefPolicy where+ show NoRef = "no-referrer"+ show SameOrigin = "same-origin"+ show StrictOrigin = "strict-origin"+ show StrictOriginCross = "strict-origin-when-cross-origin"++instance ToHttpApiData RefPolicy where+ toHeader = TE.encodeUtf8 . T.pack . show+ toQueryParam = T.pack . show++class HasApiRoot m where+ type ApiRoot m+ apiRoot :: m (Proxy (ApiRoot m))+ apiBase :: m URI++-- | A class to avoid repeated emailing someone even if they sign up multiple times.+class DedupSubscriptions m where+ recentlySubscribed :: Address -> m Bool++class HasClientSessionKey k where+ clientSessionKey :: Lens' k CS.Key++instance HasClientSessionKey CS.Key where+ clientSessionKey = id++class HasAllowedOrigins t where+ allowedOrigins :: Lens' t [URIAuth]++data NewsletterTimeouts+ = NewsletterTimeouts+ { _nltSubTimeout :: Integer+ -- ^ How long subsription confirmation links are valid for+ , _nltGrace :: Integer+ -- ^ How much extra time they have to POST the confirmation+ }+ deriving (Show)++makeClassy ''NewsletterTimeouts++type NewsletterUnsubGet =+ "unsubscribe" :> Capture "unsub" Text :> Get '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)++type NewsletterUnsubPost =+ "unsubscribe" :> Capture "unsub" Text :> Post '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)++type NewsletterUnsub =+ NewsletterUnsubGet+ :<|> NewsletterUnsubPost++type NewsletterSubGet =+ Get '[HTML] Html++type NewsletterSubPost =+ Header "Origin" String :> Header "Referer" String :> ReqBody '[FormUrlEncoded] Form :> Post '[HTML] Html++type NewsletterSubConfirmGet =+ "confirm" :> Capture "sub" Text :> Get '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy]Html)++type NewsletterSubConfirmPost =+ "confirm" :> Capture "sub" Text :> Post '[HTML] (Headers '[Header "Referrer-Policy" RefPolicy] Html)++type NewsletterSub =+ NewsletterSubGet+ :<|> NewsletterSubPost++type NewsletterSubConfirm =+ NewsletterSubConfirmGet+ :<|> NewsletterSubConfirmPost++type NewsletterAPI =+ NewsletterUnsub+ :<|> NewsletterSub+ :<|> NewsletterSubConfirm++newsletterApi :: Proxy NewsletterAPI+newsletterApi = Proxy++genUnsubLink :: (HasClientSessionKey k, MonadIO m, MonadReader k m, HasApiRoot m+ ,IsElem NewsletterUnsubGet (ApiRoot m))+ => Address -> m URI+genUnsubLink (Address _ email) = do+ k <- view clientSessionKey+ e <- liftIO $ CS.encryptIO k (TE.encodeUtf8 email)+ u <- apiBase+ ((`relativeTo` u) . linkURI) <$> (safeLink <$> apiRoot+ <*> pure (Proxy @NewsletterUnsubGet)+ <*> pure (TE.decodeUtf8 e))++genSubConfirmLink :: (HasClientSessionKey k, MonadIO m, MonadReader k m, HasApiRoot m+ ,IsElem NewsletterSubConfirmGet (ApiRoot m))+ => Address -> m URI+genSubConfirmLink (Address _ email) = do+ now <- utctDay <$> liftIO getCurrentTime+ u <- apiBase+ ((`relativeTo` u) . linkURI) <$> (safeLink <$> apiRoot+ <*> pure (Proxy @NewsletterSubConfirmGet)+ <*> encSignup (SignupReq now email))++encSignup :: (HasClientSessionKey k, MonadIO m, MonadReader k m)+ => SignupReq -> m Text+encSignup (SignupReq now email) = do+ k <- view clientSessionKey+ let ts = formatTime defaultTimeLocale (iso8601DateFormat Nothing) now+ let st = T.pack $ printf "1%s:%s" ts email+ TE.decodeUtf8 <$> liftIO (CS.encryptIO k (TE.encodeUtf8 st))++decSignup :: (HasClientSessionKey k, MonadReader k m)+ => Text -> m (Maybe SignupReq)+decSignup t = do+ k <- view clientSessionKey+ return $ do+ dt <- TE.decodeUtf8 <$> CS.decrypt k (TE.encodeUtf8 t)+ case T.splitAt 1 dt of+ ("1", r) -> do+ let (dayStr, email) = T.drop 1 <$> T.breakOn ":" r+ SignupReq <$> (parseTimeM False defaultTimeLocale (iso8601DateFormat Nothing) $+ T.unpack dayStr)+ <*> pure email+ _ -> Nothing++decodeCS :: (HasClientSessionKey k, MonadReader k m)+ => (ByteString -> Maybe b) -> Text -> m (Maybe b)+decodeCS f t =+ (join . fmap f) <$> (CS.decrypt <$> view clientSessionKey <*> pure (TE.encodeUtf8 t))++data SignupReq+ = SignupReq+ { _signupTime :: Day+ -- ^ Makes sure a singup isn't value forever+ , _signupAddress :: Text+ }+ deriving (Show, Eq, Ord)+
+ src/Network/Mail/Newsletter/Web/Dedup/InMem.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Mail.Newsletter.Web.Dedup.InMem+ ( InMemoryDedup(..)+ , newInMemDedup+ , HasInMemoryDedup(..)+ , genericInMemRecentlySubscribed+ ) where++import Control.Concurrent.STM+import Control.Lens+import Control.Monad.Reader+import Data.HashPSQ (HashPSQ)+import qualified Data.HashPSQ as PSQ+import Data.Time+import Data.Text (Text)+import Network.Mail.Mime++data InMemoryDedup+ = InMemoryDedup+ { _psqTimeout :: NominalDiffTime+ , _psqSubscribes :: TVar (HashPSQ Text UTCTime ())+ }++makeClassy ''InMemoryDedup++newInMemDedup :: MonadIO m => NominalDiffTime -> m InMemoryDedup+newInMemDedup d = liftIO $ InMemoryDedup d <$> newTVarIO PSQ.empty++genericInMemRecentlySubscribed :: (HasInMemoryDedup d, MonadReader d m, MonadIO m)+ => Address -> m Bool+genericInMemRecentlySubscribed (Address _ email) = do+ now <- liftIO getCurrentTime+ p <- view psqSubscribes+ d <- view psqTimeout+ liftIO . atomically . stateTVar p $ \s' -> do+ let (_, s) = PSQ.atMostView ((-d) `addUTCTime` now) s'+ case PSQ.lookup email s of+ Nothing -> (True, PSQ.insert email now () s)+ Just _ -> (False, s)
+ src/Network/Mail/Newsletter/Web/Handlers.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+module Network.Mail.Newsletter.Web.Handlers+ ( serveNewsletter+ , serverNewsletterSubGet, serverNewsletterSubPost+ , serverNewsletterSubConfirmGet, serverNewsletterSubConfirmPost+ , serverNewsletterUnsubGet, serverNewsletterUnsubPost+ ) where++import Control.Lens+import Control.Monad.Error.Class+import Control.Monad.Reader+import qualified Data.Aeson as JS+import qualified Data.HashMap.Strict as HM+import Data.Machine+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time+import Network.Mail.Mime (Address(..))+import Network.Mail.Newsletter.Class+import Network.Mail.Newsletter.Web.API+import Network.Mail.Newsletter.Web.Templates+import Network.URI+import Servant+import System.Random+import Text.Blaze.Html+import qualified Web.ClientSession as CS+import Web.FormUrlEncoded++-- We can make this auto-batching later.+doUnsub :: (Monad m, Newsletter m) => Address -> m ()+doUnsub addr = runT_ $ source [addr] ~> unsubscribe++serveNewsletter :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,IsElem NewsletterUnsubGet (ApiRoot m)+ ,MonadReader r m, MonadError ServantErr m, Newsletter m+ ,DedupSubscriptions m, HasNewsletterTimeouts r, HasAllowedOrigins r+ ,MonadIO m)+ => ServerT NewsletterAPI m+serveNewsletter =+ (serverNewsletterUnsubGet :<|> serverNewsletterUnsubPost)+ :<|> (serverNewsletterSubGet :<|> serverNewsletterSubPost)+ :<|> (serverNewsletterSubConfirmGet :<|> serverNewsletterSubConfirmPost)++serverNewsletterUnsubGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)+ => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)+serverNewsletterUnsubGet csAddr = addHeader StrictOrigin <$> do+ mAddr <- decodeCS (Just . Address Nothing . TE.decodeUtf8) csAddr+ case mAddr of+ Just addr -> join $ view unsubConfirmTempl <*> pure addr+ Nothing -> throwError err400++serverNewsletterUnsubPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)+ => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)+serverNewsletterUnsubPost csAddr = addHeader StrictOrigin <$> do+ maddr <- decodeCS (Just . Address Nothing . TE.decodeUtf8) csAddr+ case maddr of+ Just addr -> do+ doUnsub addr+ join $ view unsubTempl <*> pure addr+ Nothing ->+ throwError err400++serverNewsletterSubGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,MonadReader r m, MonadError ServantErr m, Newsletter m, MonadIO m)+ => m Html+serverNewsletterSubGet = do+ dk <- T.pack <$> liftIO (replicateM 5 (randomRIO ('a', 'z')))+ gk <- T.pack <$> liftIO (replicateM 5 (randomRIO ('a', 'z')))+ gv <- T.pack <$> liftIO (replicateM 5 (randomRIO ('a', 'z')))+ k <- view clientSessionKey+ f <- TE.decodeUtf8 <$> liftIO (CS.encryptIO k (TE.encodeUtf8 $ T.intercalate ":" [dk, gk, gv]))+ join $ view subStartPage <*> pure f <*> pure dk <*> pure gk <*> pure gv++serverNewsletterSubPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,MonadReader r m, MonadError ServantErr m, Newsletter m+ ,DedupSubscriptions m, HasAllowedOrigins r, MonadIO m)+ => Maybe String -> Maybe String -> Form -> m Html+serverNewsletterSubPost morig mref frm = do+ asrc <- view allowedOrigins+ k <- view clientSessionKey+ case (join $ uriAuthority <$> maybe (parseAbsoluteURI =<< mref) parseAbsoluteURI morig+ ,checkFormSec k) of+ (Nothing, _) -> throwError err400+ (Just a, Right True) | a `elem` asrc -> do+ case HM.lookup "email" (unForm frm) of+ Just [email] -> do+ let addr = Address Nothing email+ join $ when <$> recentlySubscribed addr+ <*> pure (sendSubscribe addr =<< join (view optInEmail <*> pure addr))+ join $ view subStartSubmitted <*> pure addr+ _ -> throwError err400+ _ -> throwError err403+ where+ checkFormSec :: CS.Key -> Either Text Bool+ checkFormSec k = do+ f <- parseUnique "f" frm+ case (T.splitOn ":" . TE.decodeUtf8) <$> CS.decrypt k (TE.encodeUtf8 f) of+ Just [dk,gk,gv] -> do+ d <- (==(""::Text)) <$> parseUnique dk frm+ g <- (== gv) <$> parseUnique gk frm+ Right (d&&g)+ _ -> pure False++serverNewsletterSubConfirmGet :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,MonadReader r m, MonadError ServantErr m, Newsletter m+ ,HasNewsletterTimeouts r, MonadIO m)+ => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)+serverNewsletterSubConfirmGet csAddr = addHeader StrictOrigin <$> do+ now <- utctDay <$> liftIO getCurrentTime+ msr <- decSignup csAddr+ tout <- view nltSubTimeout+ case msr of+ Just (SignupReq day email) | (day `diffDays` now) < tout ->+ join $ view confirmStart <*> pure (Address Nothing email)+ _ -> throwError err400++serverNewsletterSubConfirmPost :: (HasClientSessionKey r, HasApiRoot m, HasNlTemplates r m+ ,IsElem NewsletterUnsubGet (ApiRoot m)+ ,MonadReader r m, MonadError ServantErr m, Newsletter m+ ,HasNewsletterTimeouts r, MonadIO m)+ => Text -> m (Headers '[Header "Referrer-Policy" RefPolicy] Html)+serverNewsletterSubConfirmPost csAddr = addHeader StrictOrigin <$> do+ now <- liftIO getCurrentTime+ msr <- decSignup csAddr+ tout <- (+) <$> view nltSubTimeout <*> view nltGrace+ case msr of+ Just (SignupReq day email) | (day `diffDays` (utctDay now)) < tout -> do+ let addr = Address Nothing email+ unsub <- genUnsubLink addr+ runT_ $ source [(addr, JS.object [("subscribedAt", JS.toJSON now)+ ,("unsubscribe", JS.toJSON $ show unsub)])] ~> subscribe+ join $ view confirmConfirmed <*> pure addr+ _ -> throwError err400
+ src/Network/Mail/Newsletter/Web/Templates.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Network.Mail.Newsletter.Web.Templates+ ( NlTemplates(..)+ , HasNlTemplates(..)+ , defTemplates+ , defSubStart+ , defSubAwaitEmail+ , defOptInEmail+ , defConf+ , defConfed+ , defUnsubConf+ , defUnsubbed+ ) where++import Control.Lens+import Control.Monad.Reader+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Network.Mail.Mime+import Network.Mail.Newsletter.Web.API+import Servant+import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text (renderHtml)+import qualified Text.Blaze.Html5 as HTML5+import qualified Text.Blaze.Html5.Attributes as HTML5A+import Text.Printf++data NlTemplates m+ = NlTemplates+ { _subStartPage :: (HasApiRoot m)+ => Text -> Text -> Text -> Text -> m Html+ -- ^ The sign up start form page.+ , _subStartSubmitted :: (HasApiRoot m)+ => Address -> m Html+ -- ^ The page the sign up form lands at.+ , _optInEmail :: (HasApiRoot m)+ => Address -> m (Address -> Mail)+ -- ^ Given the potential new subsriber, generate the opt-in email to them.+ , _confirmStart :: (HasApiRoot m)+ => Address -> m Html+ -- ^ The page people land on from the email to confirm they want to subscribe.+ , _confirmConfirmed :: (HasApiRoot m)+ => Address -> m Html+ -- ^ The page that confirms they have completed subscribing.+ , _unsubConfirmTempl :: (HasApiRoot m)+ => Address -> m Html+ -- ^ A page with an unsubscribe button for a given user.+ -- The URI is the form POST destination, the Address is+ -- the addres of the unsubscribing user.+ , _unsubTempl :: (HasApiRoot m)+ => Address -> m Html+ -- ^ The page notifying you of sucessful unsubscription.+ }++makeClassy ''NlTemplates++defTemplates :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m+ ,IsElem NewsletterSubConfirmGet (ApiRoot m))+ => NlTemplates m+defTemplates =+ NlTemplates+ { _subStartPage = defSubStart (pure ())+ , _subStartSubmitted = defSubAwaitEmail+ , _optInEmail = defOptInEmail "Newsletter signup confirmation email"+ , _confirmStart = defConf+ , _confirmConfirmed = defConfed+ , _unsubConfirmTempl = defUnsubConf+ , _unsubTempl = defUnsubbed+ }++defSubStart :: Monad m => Html -> Text -> Text -> Text -> Text -> m Html+defSubStart desc f dk gk gv = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ desc+ HTML5.form ! HTML5A.method "POST" $ do+ HTML5.input ! HTML5A.type_ "email" ! HTML5A.name "email"+ HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name "f"+ ! HTML5A.value (HTML5.toValue f)+ HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name (HTML5.toValue dk)+ ! HTML5A.value (HTML5.toValue (""::Text))+ HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name (HTML5.toValue gk)+ ! HTML5A.value (HTML5.toValue gv)+ HTML5.input ! HTML5A.type_ "submit" ! HTML5A.value "subscribe"++defSubAwaitEmail :: Monad m => Address -> m Html+defSubAwaitEmail subAddr = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ toMarkup . mconcat $+ [ "You should receive an email at "+ , renderAddress subAddr+ , " shortly which will enable you to complete the signup process."+ ]++defOptInEmail :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m+ ,IsElem NewsletterSubConfirmGet (ApiRoot m))+ => Text -> Address -> m (Address -> Mail)+defOptInEmail subject toAddr = do+ l <- genSubConfirmLink toAddr+ let tl = TL.pack $ show l+ let p1 = mconcat $+ [ "We have received a request for subscription of your email address, \""+ , TL.fromStrict (renderAddress toAddr), "\" to this mailing list. To confirm you wish to be added to this "+ , " mailing list visit:"+ ]+ let p2 = "If you do not wish to be subscribed no action is required."+ let plainBody = mconcat $+ [ p1+ , "\n\n"+ , tl+ , "\n\n"+ , p2+ ]+ let htmlBody = renderHtml $ do+ HTML5.p $ toMarkup p1+ HTML5.a ! HTML5A.href (toValue tl) $ toMarkup tl+ HTML5.p $ toMarkup p2+ return $ \fromAddr ->+ simpleMailInMemory+ toAddr+ fromAddr+ subject+ plainBody+ htmlBody+ []++defConf :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m+ ,IsElem NewsletterSubConfirmGet (ApiRoot m))+ => Address -> m Html+defConf addr = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ HTML5.p $ "To complete the subscription process, you click the button below."+ HTML5.form ! HTML5A.method "POST" $ do+ HTML5.input ! HTML5A.type_ "submit"+ ! HTML5A.value (toValue (printf "Confirm subscription %s" (renderAddress addr)::String))++defConfed :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m)+ => Address -> m Html+defConfed addr = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ toMarkup (printf "Subscription for %s confirmed." (renderAddress addr)::String)++defUnsubConf :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m+ ,IsElem NewsletterSubConfirmGet (ApiRoot m))+ => Address -> m Html+defUnsubConf (Address _ e) = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ HTML5.form ! HTML5A.method "POST" $ do+ HTML5.input ! HTML5A.type_ "submit"+ ! HTML5A.value (toValue (printf "Unsubscribe %s" e::String))++defUnsubbed :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m)+ => Address -> m Html+defUnsubbed _ = do+ pure . HTML5.docTypeHtml $ do+ HTML5.head $ pure ()+ HTML5.body $ do+ "Your unsubscription has been processed"
+ tools/Server.hs view
@@ -0,0 +1,86 @@+{-# 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