chore(tazblog): Format source files with ormolu r/60

Ormolu's formatting is quite annoying (it uses a lot of unnecessary vertical space and doesn't align elements), but I can't be bothered to do manual formatting - especially because whatever formatting haskell-mode in Emacs produces seems to depend on an opaque state machine or something.
author: Vincent Ambo <tazjin@google.com> 2019-08-25T19·15+0100
committer: Vincent Ambo <tazjin@google.com> 2019-08-25T19·15+0100
commit: 1747df418e8cdd5d9de1a643354d7ac28591ed14 (patch)
tree: d2d2ff27374bd40f5c3bcdf366343b1b76297a1c /services/tazblog/src
parent: 2fdc87222871e6b68ba2d7ee1c634cfa0d75c572 (diff)
5 files changed, 187 insertions, 151 deletions
diff --git a/services/tazblog/src/Blog.hs b/services/tazblog/src/Blog.hs
index d02836a3f3ac..15ac9993eba4 100644
--- a/services/tazblog/src/Blog.hs
+++ b/services/tazblog/src/Blog.hs
@@ -1,26 +1,25 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Blog where
 
 import BlogStore
-import           Data.Text       (Text, empty, pack)
-import           Data.Text.Lazy  (fromStrict)
-import           Data.Time
-import           Locales
-import           Text.Blaze.Html (preEscapedToHtml)
-import           Text.Hamlet
-import           Text.Markdown
-
-import qualified Data.Text       as T
+import Data.Text (Text, empty, pack)
+import qualified Data.Text as T
+import Data.Text.Lazy (fromStrict)
+import Data.Time
+import Locales
+import Text.Blaze.Html (preEscapedToHtml)
+import Text.Hamlet
+import Text.Markdown
 
 replace :: Eq a => a -> a -> [a] -> [a]
 replace x y = map (\z -> if z == x then y else z)
@@ -29,9 +28,9 @@ replace x y = map (\z -> if z == x then y else z)
 markdownCutoff :: Day
 markdownCutoff = fromGregorian 2013 04 28
 
--- blog HTML
 blogTemplate :: BlogLang -> Text -> Html -> Html
-blogTemplate lang t_append body = [shamlet|
+blogTemplate lang t_append body =
+  [shamlet|
 $doctype 5
   <head>
     <meta charset="utf-8">
@@ -48,11 +47,12 @@ $doctype 5
     ^{body}
     ^{showFooter}
 |]
- where
-  rssUrl = T.concat ["/", show' lang, "/rss.xml"]
+  where
+    rssUrl = T.concat ["/", show' lang, "/rss.xml"]
 
 showFooter :: Html
-showFooter = [shamlet|
+showFooter =
+  [shamlet|
 <footer>
   <p .footer>Served without any dynamic languages.
   <p .footer>
@@ -72,7 +72,8 @@ renderEntryMarkdown :: Text -> Html
 renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
 
 renderEntries :: [Entry] -> Maybe Html -> Html
-renderEntries entries pageLinks = [shamlet|
+renderEntries entries pageLinks =
+  [shamlet|
 $forall entry <- entries
   <article>
     <h2 .inline>
@@ -93,10 +94,11 @@ $maybe links <- pageLinks
   ^{links}
 |]
   where
-   linkElems Entry{..} = concat $ ["/", show lang, "/", show entryId]
+    linkElems Entry {..} = concat $ ["/", show lang, "/", show entryId]
 
 showLinks :: Maybe Int -> BlogLang -> Html
-showLinks (Just i) lang = [shamlet|
+showLinks (Just i) lang =
+  [shamlet|
   $if ((>) i 1)
     <div .navigation>
       <a href=#{nLink $ succ i} .uncoloured-link>#{backText lang}
@@ -106,16 +108,18 @@ showLinks (Just i) lang = [shamlet|
     ^{showLinks Nothing lang}
 |]
   where
-   nLink page = T.concat ["/", show' lang, "/?page=", show' page]
-showLinks Nothing lang = [shamlet|
+    nLink page = T.concat ["/", show' lang, "/?page=", show' page]
+showLinks Nothing lang =
+  [shamlet|
 <div .navigation>
   <a href=#{nLink} .uncoloured-link>#{backText lang}
 |]
   where
-   nLink = T.concat ["/", show' lang, "/?page=2"]
+    nLink = T.concat ["/", show' lang, "/?page=2"]
 
 renderEntry :: Entry -> Html
-renderEntry e@Entry{..} = [shamlet|
+renderEntry e@Entry {..} =
+  [shamlet|
 <article>
   <h2 .inline>
     #{title}
@@ -131,12 +135,16 @@ renderEntry e@Entry{..} = [shamlet|
 |]
 
 showError :: BlogError -> BlogLang -> Html
-showError NotFound l = blogTemplate l (T.append ": " $ notFoundTitle l) $ [shamlet|
+showError NotFound l =
+  blogTemplate l (T.append ": " $ notFoundTitle l)
+    $ [shamlet|
 <p>:(
 <p>#{notFoundText l}
 <hr>
 |]
-showError UnknownError l = blogTemplate l "" $ [shamlet|
+showError UnknownError l =
+  blogTemplate l ""
+    $ [shamlet|
 <p>:(
 <p>#{unknownErrorText l}
 <hr>
diff --git a/services/tazblog/src/BlogStore.hs b/services/tazblog/src/BlogStore.hs
index a91db060b825..0472fef56bc9 100644
--- a/services/tazblog/src/BlogStore.hs
+++ b/services/tazblog/src/BlogStore.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 -- |This module implements fetching of individual blog entries from
 -- DNS. Yes, you read that correctly.
 --
@@ -15,49 +19,47 @@
 --
 -- This module implements logic for assembling a post out of these
 -- fragments and caching it based on the TTL of its `_meta` record.
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module BlogStore
+  ( BlogCache,
+    EntryId (..),
+    Entry (..),
+    withCache,
+    listEntries,
+    getEntry,
+    show'
+    )
+where
 
-module BlogStore(
-  BlogCache,
-  EntryId(..),
-  Entry(..),
-  withCache,
-  listEntries,
-  getEntry,
-  show',
-) where
-
-import Data.Aeson ((.:), FromJSON(..), Value(Object), decodeStrict)
 import Control.Applicative ((<$>), (<*>))
 import Control.Monad (mzero)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.Aeson ((.:), FromJSON (..), Value (Object), decodeStrict)
+import Data.ByteString.Base64 (decodeLenient)
+import Data.Either (fromRight)
+import Data.List (sortBy)
 import Data.Text as T (Text, concat, pack)
-import Data.Text.Encoding (encodeUtf8, decodeUtf8')
+import Data.Text.Encoding (decodeUtf8', encodeUtf8)
 import Data.Time (Day)
 import Locales (BlogLang (..))
-import Network.DNS (lookupTXT, DNSError)
+import Network.DNS (DNSError, lookupTXT)
 import qualified Network.DNS.Resolver as R
-import Data.ByteString.Base64 (decodeLenient)
-import Data.List (sortBy)
-import Data.Either (fromRight)
 
 newtype EntryId = EntryId {unEntryId :: Integer}
   deriving (Eq, Ord, FromJSON)
 
 instance Show EntryId where
+
   show = show . unEntryId
 
 data Entry
   = Entry
       { entryId :: EntryId,
-        lang    :: BlogLang,
-        author  :: Text,
-        title   :: Text,
-        btext   :: Text,
-        mtext   :: Text,
-        edate   :: Day
+        lang :: BlogLang,
+        author :: Text,
+        title :: Text,
+        btext :: Text,
+        mtext :: Text,
+        edate :: Day
         }
   deriving (Eq, Ord, Show)
 
@@ -80,20 +82,22 @@ type Count = Int
 
 withCache :: Text -> (BlogCache -> IO a) -> IO a
 withCache zone f = do
-  let conf = R.defaultResolvConf { R.resolvCache = Just R.defaultCacheConf
-                                 , R.resolvConcurrent = True }
+  let conf =
+        R.defaultResolvConf
+          { R.resolvCache = Just R.defaultCacheConf,
+            R.resolvConcurrent = True
+            }
   seed <- R.makeResolvSeed conf
   R.withResolver seed $ (\r -> f $ BlogCache r zone)
 
-
 listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
 listEntries cache offset count = liftIO $ do
   posts <- postList cache
   entries <- mapM (entryFromDNS cache) $ take count $ drop offset $ fromRight (error "no posts") posts
-
   -- TODO: maybe don't just drop broken entries
   return
-    $ fromRight (error "no entries") $ sequence entries
+    $ fromRight (error "no entries")
+    $ sequence entries
 
 getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
 getEntry cache eid = liftIO $ (entryFromDNS cache eid) >>= \case
@@ -104,7 +108,6 @@ show' :: Show a => a -> Text
 show' = pack . show
 
 -- * DNS fetching implementation
-
 type Chunk = Integer
 
 -- | Represents the metadata stored for each post in the _meta record.
@@ -112,23 +115,28 @@ data Meta = Meta Integer Text Day
   deriving (Show)
 
 instance FromJSON Meta where
-  parseJSON (Object v) = Meta <$>
-    v .: "c" <*>
-    v .: "t" <*>
-    v .: "d"
+
+  parseJSON (Object v) =
+    Meta
+      <$> v
+      .: "c"
+      <*> v
+      .: "t"
+      <*> v
+      .: "d"
   parseJSON _ = mzero
 
 entryMetadata :: BlogCache -> EntryId -> IO (Either StoreError Meta)
 entryMetadata (BlogCache r z) (EntryId eid) =
   let domain = encodeUtf8 ("_meta." <> show' eid <> "." <> z)
       record = lookupTXT r domain
-      toMeta rrdata = case decodeStrict $ decodeLenient rrdata  of
+      toMeta rrdata = case decodeStrict $ decodeLenient rrdata of
         Nothing -> Left InvalidMetadata
-        Just m  -> Right m
-  in record >>= \case
-    (Left err) -> return $ Left $ DNS err
-    (Right [ bs ]) -> return $ toMeta bs
-    _ -> return $ Left InvalidMetadata
+        Just m -> Right m
+   in record >>= \case
+        (Left err) -> return $ Left $ DNS err
+        (Right [bs]) -> return $ toMeta bs
+        _ -> return $ Left InvalidMetadata
 
 entryChunk :: BlogCache -> EntryId -> Chunk -> IO (Either StoreError Text)
 entryChunk (BlogCache r z) (EntryId eid) c =
@@ -137,14 +145,14 @@ entryChunk (BlogCache r z) (EntryId eid) c =
       toChunk rrdata = case decodeUtf8' $ decodeLenient rrdata of
         Left _ -> Left InvalidChunk
         Right chunk -> Right chunk
-  in record >>= \case
-    (Left err) -> return $ Left $ DNS err
-    (Right [ bs ]) -> return $ toChunk bs
-    _ -> return $ Left InvalidChunk
+   in record >>= \case
+        (Left err) -> return $ Left $ DNS err
+        (Right [bs]) -> return $ toChunk bs
+        _ -> return $ Left InvalidChunk
 
 fetchAssembleChunks :: BlogCache -> EntryId -> Meta -> IO (Either StoreError Text)
 fetchAssembleChunks cache eid (Meta n _ _) = do
-  chunks <- mapM (entryChunk cache eid) [0..(n - 1)]
+  chunks <- mapM (entryChunk cache eid) [0 .. (n - 1)]
   return $ either Left (Right . T.concat) $ sequence chunks
 
 entryFromDNS :: BlogCache -> EntryId -> IO (Either StoreError Entry)
@@ -155,19 +163,25 @@ entryFromDNS cache eid = do
     Right meta -> do
       chunks <- fetchAssembleChunks cache eid meta
       let (Meta _ t d) = meta
-      return $ either Left (\text -> Right $ Entry {
-                               entryId = eid,
-                               lang = EN,
-                               author = "tazjin",
-                               title = t,
-                               btext = text,
-                               mtext = "",
-                               edate = d}) chunks
+      return
+        $ either Left
+            ( \text -> Right $ Entry
+                { entryId = eid,
+                  lang = EN,
+                  author = "tazjin",
+                  title = t,
+                  btext = text,
+                  mtext = "",
+                  edate = d
+                  }
+              )
+            chunks
 
 postList :: BlogCache -> IO (Either StoreError [EntryId])
 postList (BlogCache r z) =
   let domain = encodeUtf8 ("_posts." <> z)
       record = lookupTXT r domain
-      toPosts = fmap (sortBy (flip compare)) . sequence .
-        map (\r -> maybe (Left InvalidPosts) Right (decodeStrict r))
-  in record >>= return . either (Left . DNS) toPosts
+      toPosts =
+        fmap (sortBy (flip compare)) . sequence
+          . map (\r -> maybe (Left InvalidPosts) Right (decodeStrict r))
+   in record >>= return . either (Left . DNS) toPosts
diff --git a/services/tazblog/src/Locales.hs b/services/tazblog/src/Locales.hs
index 2e49809eee32..79edcd75f32a 100644
--- a/services/tazblog/src/Locales.hs
+++ b/services/tazblog/src/Locales.hs
@@ -1,17 +1,20 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Locales where
 
-import           Data.Maybe  (fromMaybe)
-import           Data.Text   (Text)
-import qualified Data.Text   as T
-import           Network.URI
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Network.URI
 
 data BlogLang = EN | DE
-    deriving (Eq, Ord)
+  deriving (Eq, Ord)
 
 instance Show BlogLang where
-    show DE = "de"
-    show EN = "en"
+
+  show DE = "de"
+  show EN = "en"
 
 data BlogError = NotFound | UnknownError
 
diff --git a/services/tazblog/src/RSS.hs b/services/tazblog/src/RSS.hs
index 02a2aafda969..d3e78ba0fb85 100644
--- a/services/tazblog/src/RSS.hs
+++ b/services/tazblog/src/RSS.hs
@@ -1,42 +1,48 @@
 {-# LANGUAGE RecordWildCards #-}
-module RSS (renderFeed) where
 
-import qualified Data.Text as T
+module RSS
+  ( renderFeed
+    )
+where
 
+import BlogStore
 import Control.Monad (liftM)
-import Data.Maybe    (fromMaybe)
-import Data.Time     (UTCTime(..), getCurrentTime, secondsToDiffTime)
+import Data.Maybe (fromMaybe)
+import qualified Data.Text as T
+import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime)
+import Locales
 import Network.URI
 import Text.RSS
 
-import BlogStore
-import Locales
-
 createChannel :: BlogLang -> UTCTime -> [ChannelElem]
-createChannel l now = [ Language $ show l
-                      , Copyright "Vincent Ambo"
-                      , WebMaster "tazjin@gmail.com"
-                      , ChannelPubDate now
-                      ]
+createChannel l now =
+  [ Language $ show l,
+    Copyright "Vincent Ambo",
+    WebMaster "mail@tazj.in",
+    ChannelPubDate now
+    ]
 
 createRSS :: BlogLang -> UTCTime -> [Item] -> RSS
 createRSS l t = RSS (rssTitle l) (rssLink l) (rssDesc l) (createChannel l t)
 
 createItem :: Entry -> Item
-createItem Entry{..} = [ Title $ T.unpack title
-                       , Link $ makeLink lang entryId
-                       , Description $ T.unpack btext
-                       , PubDate $ UTCTime edate $ secondsToDiffTime 0 ]
+createItem Entry {..} =
+  [ Title $ T.unpack title,
+    Link $ makeLink lang entryId,
+    Description $ T.unpack btext,
+    PubDate $ UTCTime edate $ secondsToDiffTime 0
+    ]
 
 makeLink :: BlogLang -> EntryId -> URI
-makeLink l i = let url = "http://tazj.in/" ++ show l ++ "/" ++ show i
-               in fromMaybe nullURI $ parseURI url
+makeLink l i =
+  let url = "http://tazj.in/" ++ show l ++ "/" ++ show i
+   in fromMaybe nullURI $ parseURI url
 
 createItems :: [Entry] -> [Item]
 createItems = map createItem
 
 createFeed :: BlogLang -> [Entry] -> IO RSS
-createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e )
+createFeed l e = getCurrentTime >>= (\t -> return $ createRSS l t $ createItems e)
 
 renderFeed :: BlogLang -> [Entry] -> IO String
 renderFeed l e = liftM (showXML . rssToXML) (createFeed l e)
diff --git a/services/tazblog/src/Server.hs b/services/tazblog/src/Server.hs
index 8a7384ccca3e..492849a2f39d 100644
--- a/services/tazblog/src/Server.hs
+++ b/services/tazblog/src/Server.hs
@@ -1,16 +1,19 @@
-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-}
-module Server where
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
-import           Control.Applicative    (optional)
-import Control.Monad (msum)
-import           Control.Monad.IO.Class (liftIO)
-import           Data.Char              (toLower)
-import qualified Data.Text              as T
-import           Happstack.Server       hiding (Session)
-import Data.Maybe (maybe)
+module Server where
 
 import Blog
 import BlogStore
+import Control.Applicative (optional)
+import Control.Monad (msum)
+import Control.Monad.IO.Class (liftIO)
+import Data.Char (toLower)
+import Data.Maybe (maybe)
+import qualified Data.Text as T
+import Happstack.Server hiding (Session)
 import Locales
 import RSS
 
@@ -19,7 +22,7 @@ instance FromReqURI BlogLang where
     case map toLower sub of
       "de" -> Just DE
       "en" -> Just EN
-      _    -> Nothing
+      _ -> Nothing
 
 pageSize :: Int
 pageSize = 3
@@ -34,21 +37,23 @@ runBlog port respath = do
 
 tazBlog :: BlogCache -> String -> ServerPart Response
 tazBlog cache resDir = do
-    msum [ path $ \(lang :: BlogLang) -> blogHandler cache lang
-         , dir "static" $ staticHandler resDir
-         , blogHandler cache EN
-         , staticHandler resDir
-         , notFound $ toResponse $ showError NotFound DE
-         ]
+  msum
+    [ path $ \(lang :: BlogLang) -> blogHandler cache lang,
+      dir "static" $ staticHandler resDir,
+      blogHandler cache EN,
+      staticHandler resDir,
+      notFound $ toResponse $ showError NotFound DE
+      ]
 
 blogHandler :: BlogCache -> BlogLang -> ServerPart Response
 blogHandler cache lang =
-    msum [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId
-         , nullDir >> showIndex cache lang
-         , dir "rss" $ nullDir >> showRSS cache lang
-         , dir "rss.xml" $ nullDir >> showRSS cache lang
-         , notFound $ toResponse $ showError NotFound lang
-         ]
+  msum
+    [ path $ \(eId :: Integer) -> showEntry cache lang $ EntryId eId,
+      nullDir >> showIndex cache lang,
+      dir "rss" $ nullDir >> showRSS cache lang,
+      dir "rss.xml" $ nullDir >> showRSS cache lang,
+      notFound $ toResponse $ showError NotFound lang
+      ]
 
 staticHandler :: String -> ServerPart Response
 staticHandler resDir = do
@@ -58,29 +63,29 @@ staticHandler resDir = do
 
 showEntry :: BlogCache -> BlogLang -> EntryId -> ServerPart Response
 showEntry cache lang eId = do
-    entry <- getEntry cache eId
-    tryEntry entry lang
+  entry <- getEntry cache eId
+  tryEntry entry lang
 
 tryEntry :: Maybe Entry -> BlogLang -> ServerPart Response
 tryEntry Nothing lang = notFound $ toResponse $ showError NotFound lang
 tryEntry (Just entry) _ = ok $ toResponse $ blogTemplate eLang eTitle $ renderEntry entry
-    where
-        eTitle = T.append ": " (title entry)
-        eLang = lang entry
+  where
+    eTitle = T.append ": " (title entry)
+    eLang = lang entry
 
 offset :: Maybe Int -> Int
 offset = maybe 0 ((*) pageSize)
 
 showIndex :: BlogCache -> BlogLang -> ServerPart Response
 showIndex cache lang = do
-    (page :: Maybe Int) <- optional $ lookRead "page"
-    entries <- listEntries cache (offset page) pageSize
-    ok $ toResponse $ blogTemplate lang "" $
-        renderEntries entries (Just $ showLinks page lang)
+  (page :: Maybe Int) <- optional $ lookRead "page"
+  entries <- listEntries cache (offset page) pageSize
+  ok $ toResponse $ blogTemplate lang ""
+    $ renderEntries entries (Just $ showLinks page lang)
 
 showRSS :: BlogCache -> BlogLang -> ServerPart Response
 showRSS cache lang = do
-    entries <- listEntries cache 0 4
-    feed <- liftIO $ renderFeed lang entries
-    setHeaderM "content-type" "text/xml"
-    ok $ toResponse feed
+  entries <- listEntries cache 0 4
+  feed <- liftIO $ renderFeed lang entries
+  setHeaderM "content-type" "text/xml"
+  ok $ toResponse feed
author	Vincent Ambo <tazjin@google.com>	2019-08-25T19·15+0100
committer	Vincent Ambo <tazjin@google.com>	2019-08-25T19·15+0100
commit	1747df418e8cdd5d9de1a643354d7ac28591ed14 (patch)
tree	d2d2ff27374bd40f5c3bcdf366343b1b76297a1c /services/tazblog/src
parent	2fdc87222871e6b68ba2d7ee1c634cfa0d75c572 (diff)