diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for newsletter + +## 0 -- 2019-05-06 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/newsletter.cabal b/newsletter.cabal new file mode 100644 --- /dev/null +++ b/newsletter.cabal @@ -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 + . +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 diff --git a/src/Network/Mail/Newsletter.hs b/src/Network/Mail/Newsletter.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter.hs @@ -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 diff --git a/src/Network/Mail/Newsletter/Class.hs b/src/Network/Mail/Newsletter/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Class.hs @@ -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 () diff --git a/src/Network/Mail/Newsletter/Web.hs b/src/Network/Mail/Newsletter/Web.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Web.hs @@ -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 diff --git a/src/Network/Mail/Newsletter/Web/API.hs b/src/Network/Mail/Newsletter/Web/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Web/API.hs @@ -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) + diff --git a/src/Network/Mail/Newsletter/Web/Dedup/InMem.hs b/src/Network/Mail/Newsletter/Web/Dedup/InMem.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Web/Dedup/InMem.hs @@ -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) diff --git a/src/Network/Mail/Newsletter/Web/Handlers.hs b/src/Network/Mail/Newsletter/Web/Handlers.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Web/Handlers.hs @@ -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 diff --git a/src/Network/Mail/Newsletter/Web/Templates.hs b/src/Network/Mail/Newsletter/Web/Templates.hs new file mode 100644 --- /dev/null +++ b/src/Network/Mail/Newsletter/Web/Templates.hs @@ -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" diff --git a/tools/Server.hs b/tools/Server.hs new file mode 100644 --- /dev/null +++ b/tools/Server.hs @@ -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