Merge branch 'simplify-types'

package.yaml

@@ -20,6 +20,7 @@ dependencies:
 - pandoc
 - pandoc-types
 - text
+- time
 - twitter-conduit
 - xml-conduit
 - xml-types
@@ -29,9 +30,9 @@ library:
   dependencies:
   - aeson
   - authenticate-oauth
-  - boomerang
   - directory
   - filepath
+  - here
   - http-conduit
   - lens
   - lifted-base
@@ -42,14 +43,9 @@ library:
   - shakespeare
   - split
   - tagsoup
-  - time
   - transformers
   - twitter-types
   - unix
-  - web-routes
-  - web-routes-boomerang
-  - web-routes-happstack
-  - web-routes-th
 executables:
   multiblog:
     main: Main.hs
@@ -71,7 +67,7 @@ tests:
     - multiblog
     - HTF
     - HUnit
-    - derive
+    - generic-arbitrary
     - QuickCheck
     - quickcheck-instances
 stability: Experimental

src/App.hs

@@ -22,10 +22,6 @@ import System.Directory
 import System.Environment
 import System.FilePath
 
-import Web.Routes
-import Web.Routes.Boomerang (boomerangSiteRouteT)
-import Web.Routes.Happstack
-
 import Cache
 import Import
 import Models
@@ -39,7 +35,7 @@ import Views.Feed
 
 type App = StateT AppCache (ReaderT AppData IO)
 
-type AppPart a = RouteT Sitemap (ServerPartT App) a
+type AppPart a = ServerPartT App a
 
 loadApp ::
        String -- ^ directory to load from
@@ -87,33 +83,19 @@ site :: ServerPartT App Response
 site = do
     address <- lift $ asks appAddress
     appDir <- lift $ asks appDirectory
-    let routedSite = boomerangSiteRouteT handler sitemap
     let staticDir = appDir </> "static"
     let staticSite = serveDirectory DisableBrowsing ["index.html"] staticDir
-    implSite address "" routedSite `mplus` staticSite
-
--- Run an action in application routing context
-runRoute :: RouteT Sitemap m a -> m a
-runRoute act
-    -- Supply a known good URL (root) to run the site,
-    -- producing the result of the given action
- =
-    let (Right res) = runSite "" (boomerangSiteRouteT (const act) sitemap) []
-    in res
-
-parseRoute :: T.Text -> Either String Sitemap
-parseRoute =
-    fmap runIdentity . runSite "" (boomerangSiteRouteT pure sitemap) . segments
-  where
-    segments = decodePathInfo . T.encodeUtf8
+    let mainSite = do
+                       method GET
+                       uriRest $ \uri -> case parseURL (T.pack uri) of
+                                             Nothing -> mzero
+                                             Just route -> handler route
+    mainSite `mplus` staticSite
 
 handler :: Sitemap -> AppPart Response
 handler route =
     case route of
         Index -> index
-        Yearly y -> yearlyIndex y
-        Monthly y m -> monthlyIndex y m
-        Daily d -> dailyIndex d
         ArticleView d s -> article d s
         MetaView s f -> meta s f
         Feed lang -> feedIndex lang
@@ -124,15 +106,6 @@ handler route =
 index :: AppPart Response
 index = articleList $ const True
 
-yearlyIndex :: Integer -> AppPart Response
-yearlyIndex = articleList . byYear
-
-monthlyIndex :: Integer -> Int -> AppPart Response
-monthlyIndex year month = articleList $ byYearMonth year month
-
-dailyIndex :: Day -> AppPart Response
-dailyIndex = articleList . byDate
-
 -- Find the most relevant language preference in a request
 -- Includes: explicit GET parameter, cookie and Accept-Language header
 languageHeaderM :: AppPart LanguagePreference
@@ -169,12 +142,11 @@ articleList articleFilter = do
 
 meta :: Text -> Maybe PageFormat -> AppPart Response
 meta slug format' = do
-    let format = fromMaybe Html format'
     language <- languageHeaderM
     m <- askMeta slug
-    case format of
-        Html -> metaDisplay language m >>= okResponse
-        _ -> metaExport format language m >>= okResponse
+    case format' of
+        Nothing -> metaDisplay language m >>= okResponse
+        Just format -> metaExport format language m >>= okResponse
 
 feedIndex :: Language -> AppPart Response
 feedIndex language = do
@@ -189,4 +161,4 @@ printStylesheet :: AppPart Response
 printStylesheet = renderPrintStylesheet >>= okResponse
 
 codeStylesheet :: AppPart Response
-codeStylesheet = renderCodeStylesheet >>= okResponse
+codeStylesheet = okResponse renderCodeStylesheet

src/CrossPost.hs

@@ -21,7 +21,6 @@ import qualified Data.Text as T
 
 import Network.HTTP.Conduit (newManager, tlsManagerSettings)
 
-import Web.Routes
 import Web.Twitter.Conduit (OAuth, TWInfo(..), call, twCredential, twOAuth)
 import Web.Twitter.Conduit.Api
 import Web.Twitter.Conduit.Parameters hiding (map)
@@ -40,11 +39,11 @@ import Views
 crossPost :: App ()
 crossPost = do
     liftIO $ putStrLn "Cross-posting new articles..."
-    runRoute crossPostTwitter
+    crossPostTwitter
     liftIO $ putStrLn "All new articles cross-posted."
 
 crossPostTwitter ::
-       (MonadRoute m, URL m ~ Sitemap, MonadIO m, MonadReader AppData m) => m ()
+       (MonadIO m, MonadReader AppData m) => m ()
 crossPostTwitter = do
     mgr <- liftIO $ newManager tlsManagerSettings
     address <- asks appAddress
@@ -84,7 +83,7 @@ twitterArticleLinks statuses = do
     -- Filter out the ones for the article route
     let articleLinks =
             [ (date, slug)
-            | Right (ArticleView date slug) <- map parseRoute urls
+            | Just (ArticleView date slug) <- map parseURL urls
             ]
     -- Get the matched articles
     let articleFilter art = any (\(d, s) -> byDateSlug d s art) articleLinks

src/Import.hs

@@ -94,7 +94,7 @@ parseContent dir = do
             case M.lookup (T.pack $ tail ext) readers of
                 Nothing -> pure Nothing
                 Just reader -> do
-                    lang <- parseLanguage fileName
+                    lang <- parseLanguage (T.pack fileName)
                     case reader (T.decodeUtf8 $ sfContent file) of
                         Left err -> throwError $ show err
                         Right res -> pure (Just (lang, res))

src/Routes.hs

@@ -1,37 +1,38 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Routes where
 
 import Prelude hiding ((.))
 
 import Control.Category (Category((.)))
 
+import Data.String.Here (i)
+
+import Data.Char (isDigit)
 import Data.Text (Text)
-import qualified Data.Text as T
+import qualified Data.Text as Text
 import Data.Time
 
-import Text.Boomerang.TH (makeBoomerangs)
+import Debug.Trace
+
+import GHC.Generics
 
-import Web.Routes.Boomerang
+import Text.Read
 
 import Types.Language
 
 data PageFormat
-    = Html
-    | Pdf
+    = Pdf
     | Docx
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic)
 
--- TODO: use Boomerang for these
 formatToStr :: PageFormat -> Text
-formatToStr Html = "pdf"
 formatToStr Pdf = "pdf"
 formatToStr Docx = "docx"
 
 strToFormat :: Text -> Maybe PageFormat
-strToFormat "html" = Just Html
 strToFormat "pdf" = Just Pdf
 strToFormat "docx" = Just Docx
 strToFormat _ = Nothing
@@ -40,10 +41,6 @@ type MaybeFormat = Maybe PageFormat
 
 data Sitemap
     = Index
-    | Yearly Integer
-    | Monthly Integer
-              Int
-    | Daily Day
     | ArticleView Day
                   Text
     | MetaView Text
@@ -52,89 +49,57 @@ data Sitemap
     | SiteScript
     | PrintStylesheet
     | CodeStylesheet
-    deriving (Eq, Ord, Show)
-
-makeBoomerangs ''Sitemap
-
-rDay :: Boomerang TextsError [Text] r (Day :- r)
-rDay = xpure mkDay parseDay . (integer </> int </> int)
-  where
-    mkDay (y :- m :- d :- x) = fromGregorian y m d :- x
-    parseDay (day :- x) =
-        let (y, m, d) = toGregorian day
-        in Just $ y :- m :- d :- x
-
--- TODO: This will error on strings which are not language codes
-rLanguage :: Boomerang TextsError [Text] r (Language :- r)
-rLanguage = xpure mkLang parseLang . anyString
-  where
-    mkLang (str :- x) =
-        let Just lang = parseLanguageM str
-        in lang :- x
-    parseLang (lang :- x) = Just $ showLanguage lang :- x
-
-rString :: Boomerang e tok i (Text :- o) -> Boomerang e tok i (String :- o)
-rString = xmaph T.unpack (Just . T.pack)
-
-anyString :: Boomerang TextsError [Text] o (String :- o)
-anyString = rString anyText
-
-rExtension ::
-       Boomerang e tok i (Text :- o)
-    -> Boomerang e tok i (Text :- Maybe Text :- o)
-rExtension = xmap splitExt' (Just . joinExt')
-  where
-    splitExt' :: Text :- o -> Text :- Maybe Text :- o
-    splitExt' (seg :- o) =
-        let (seg', ext) = splitExt seg
-        in seg' :- ext :- o
-    joinExt' :: Text :- Maybe Text :- o -> Text :- o
-    joinExt' (seg :- ext :- o) = joinExt seg ext :- o
-
--- Swap the top 2 components in a Boomerang
-xflip :: Boomerang e tok i (a :- b :- o) -> Boomerang e tok i (b :- a :- o)
-xflip = xmap pflip (Just . pflip)
-  where
-    pflip (a :- b :- o) = b :- a :- o
-
--- Apply a transformation to the second topmost component of a Boomerang
-xmaph2 ::
-       (b -> c)
-    -> (c -> Maybe b)
-    -> Boomerang e tok i (a :- b :- o)
-    -> Boomerang e tok i (a :- c :- o)
-xmaph2 f g = xflip . xmaph f g . xflip
-
--- Split a path component into basename and extension
-splitExt :: Text -> (Text, Maybe Text)
-splitExt segment =
-    case T.splitOn "." segment of
-        [] -> ("", Nothing)
-        [s] -> (s, Nothing)
-        ss -> (T.intercalate "." $ init ss, Just $ last ss)
+    deriving (Eq, Ord, Show, Generic)
+
+routeURL :: Sitemap -> Text
+routeURL Index = ""
+routeURL (ArticleView date text) = let (year, month, day) = toGregorian date in [i|/${pad 2 year}-${pad 2 month}-${pad 2 day}/${text}|]
+routeURL (MetaView text Nothing) = [i|/${text}|]
+routeURL (MetaView text (Just format)) = [i|/${text}.${formatToStr format}|]
+routeURL (Feed language) = [i|/feed/${showLanguage language}|]
+routeURL SiteScript = "/assets/site.js"
+routeURL PrintStylesheet = "/assets/print.css"
+routeURL CodeStylesheet = "/assets/code.css"
+
+pad :: Show a => Int -> a -> Text
+pad len str = let printed = Text.pack (show str)
+                  padding = Text.replicate (len - Text.length printed) "0"
+               in padding <> printed
+
+splitNonEmpty :: Text -> Text -> [Text]
+splitNonEmpty splitter = filter (not . Text.null) . Text.splitOn splitter
+
+readText :: Read a => Text -> Maybe a
+readText = readMaybe . Text.unpack
+
+parseURL :: Text -> Maybe Sitemap
+parseURL = parseSegments . splitNonEmpty "/" . dropQueryParams
+    where
+        parseSegments [] = Just Index
+        parseSegments [metaText] = case splitNonEmpty "." metaText of
+                                                              [text] -> Just $ MetaView text Nothing
+                                                              [text, formatStr] -> do
+                                                                                    format <- strToFormat formatStr
+                                                                                    pure $ MetaView text (Just format)
+                                                              _ -> Nothing
+        parseSegments [date, articleText] | dateLike date = parseArticle (splitNonEmpty "-" date) articleText
+        parseSegments [year, month, day, articleText] = parseArticle [year, month, day] articleText
+        parseSegments ["assets", "site.js"] = Just SiteScript
+        parseSegments ["assets", "print.css"] = Just PrintStylesheet
+        parseSegments ["assets", "code.css"] = Just CodeStylesheet
+        parseSegments ["feed", lang] = Feed <$> parseLanguageM lang
+        parseSegments _ = Nothing
+        dateLike = Text.all $ \c -> isDigit c || c == '-'
+        parseArticle [yearStr, monthStr, dayStr] text = do
+                                                   year <- readText yearStr
+                                                   month <- readText monthStr
+                                                   day <- readText dayStr
+                                                   date <- fromGregorianValid year month day
+                                                   pure $ ArticleView date text
+        parseArticle _ _ = Nothing
+        dropQueryParams = Text.takeWhile (/= '?')
 
 -- Join a basename and extension together
 joinExt :: Text -> Maybe Text -> Text
 joinExt segment Nothing = segment
 joinExt segment (Just ext) = segment <> "." <> ext
-
--- Convert the second topmost component into a MaybeFormat
-xFormat ::
-       Boomerang e tok i (Text :- Maybe Text :- o)
-    -> Boomerang e tok i (Text :- MaybeFormat :- o)
-xFormat = xmaph2 (strToFormat =<<) (Just . fmap formatToStr)
-
-sitemap :: Boomerang TextsError [Text] r (Sitemap :- r)
-sitemap =
-    mconcat
-        [ rIndex
-        , rYearly . integer
-        , rMonthly . integer </> int
-        , rDaily . rDay
-        , rFeed . "feed" </> rLanguage
-        , rSiteScript . "site.js"
-        , rPrintStylesheet . "print.css"
-        , rCodeStylesheet . "code.css"
-        , rArticleView . rDay </> anyText
-        , rMetaView . xFormat (rExtension anyText)
-        ]