Merge branch 'static'

- Integration test framework (fixes #8)
- Load content upfront (fixes #6)

multiblog.cabal

@@ -24,6 +24,7 @@ Executable multiblog
     filepath >= 1.3,
     happstack >= 7.0,
     happstack-server >= 7.3,
+    iso639 >= 0.1.0.3,
     mtl >= 2.1 && < 2.3,
     network >= 2.6,
     pandoc >= 1.13,
@@ -56,11 +57,14 @@ Test-Suite tests
     filepath >= 1.3,
     happstack >= 7.0,
     happstack-server >= 7.3,
+    iso639 >= 0.1.0.3,
     mtl >= 2.1 && < 2.3,
     pandoc >= 1.13,
     pandoc-types >= 1.12,
     shakespeare >= 2.0,
     split >= 0.2,
     time >= 1.4 && < 1.6,
+    derive >= 2.5,
     HTF >= 0.12,
+    HUnit >= 1.2,
     base >= 4.4 && < 5

src/App.hs

@@ -20,25 +20,27 @@ import Routes
 import Utils
 import Views
 
-
+-- TODO: This should be a ReaderT
 type App = StateT AppState IO
 
 type AppPart a = RouteT Sitemap (ServerPartT App) a
 
-runApp :: App a -> IO a
-runApp a = do
-    loaded <- loadFromDirectory "content"
-    case loaded of
+loadApp :: String -> IO AppState
+loadApp dataDirectory = do
+    app <- loadFromDirectory dataDirectory
+    case app of
         Left err -> error err
-        Right appState -> do
-            print appState
-            evalStateT a appState
+        Right appState -> return appState
 
-site :: Site Sitemap (ServerPartT App Response)
-site = boomerangSiteRouteT handler sitemap
+runApp :: AppState -> App a -> IO a
+runApp app a = evalStateT a app
 
-siteHandler :: String -> ServerPartT App Response
-siteHandler address = implSite (T.pack address) "" site
+site :: String -> ServerPartT App Response
+site address = do
+    appDir <- lift $ gets appDirectory
+    let routedSite = boomerangSiteRouteT handler sitemap
+    let staticSite = serveDirectory DisableBrowsing [] $ appDir ++ "/static"
+    implSite (T.pack address) "" routedSite `mplus` staticSite
 
 handler :: Sitemap -> AppPart Response
 handler route = case route of
@@ -59,7 +61,7 @@ monthlyIndex :: Integer -> Int -> AppPart Response
 monthlyIndex year month = articleList $ byYearMonth year month
 
 dailyIndex :: Day -> AppPart Response
-dailyIndex date = articleList $ byDate date
+dailyIndex = articleList . byDate
 
 languageHeaderM :: AppPart LanguagePreference
 languageHeaderM = do

src/Import.hs

@@ -64,16 +64,29 @@ metaValues name matchPath source = maybeToList (lookupMeta name m >>= metaText)
     where (Pandoc m _) = csContent source
           fpChunks = if matchPath then chunks $ csPath source else []
 
+-- Extract a value of a specific type from a content source
+metaValue :: String -- The meta attribute name to extract
+          -> Bool -- Whether to also extract from the file path
+          -> (String -> Maybe a) -- A function to parse a value
+          -> ContentSource -- Content source
+          -> Maybe a -- Extracted value
+metaValue name matchPath readFunc source =
+    msum $ readFunc <$> metaValues name matchPath source
+
 -- Extract a string attribute from a content source
 stringMeta :: String -- Attribute name
            -> ContentSource -- Content source
            -> Maybe String -- Attribute value
 stringMeta name = listToMaybe . metaValues name False
 
+-- Extract a language from a content source
+langMeta :: ContentSource -> Maybe Language
+langMeta = metaValue "lang" False parseLanguage
+
 -- Extract a date attribute from a content source
 -- The file path chunks will be considered as well
 dateMeta :: ContentSource -> Maybe UTCTime
-dateMeta s = msum $ readDate <$> metaValues "date" True s
+dateMeta = metaValue "date" True readDate
 
 -- A map of supported file formats and corresponding Pandoc readers
 readers :: M.Map String (String -> Pandoc)
@@ -87,7 +100,7 @@ loadFromDirectory path = do
     return $ do
         state <- fromSources sources
         strings <- loadStrings stringsFile
-        return $ state { appStrings = strings }
+        return $ state { appDirectory = path, appStrings = strings }
 
 -- All content sources from a directory
 sourcesFromDirectory :: FilePath -> IO [ContentSource]
@@ -120,7 +133,8 @@ fromSources sources = do
     let grouped = M.elems $ groupSources sources
     extracted <- mapM makeArticle grouped
     let (articles, meta) = partitionEithers extracted
-    return AppState { appArticles = articles
+    return AppState { appDirectory = ""
+                    , appArticles = articles
                     , appMeta = meta
                     , appStrings = M.empty
                     }
@@ -149,7 +163,7 @@ makeArticle ss@(s1:_) = do
 -- Merge language content from a group of sources
 mergeLanguageContent :: [ContentSource] -> Either String LanguageContent
 mergeLanguageContent ss = liftM M.fromList $ forM ss $ \s -> do
-    lang <- mfes s "Language is required" $ stringMeta "lang" s
+    lang <- mfes s "Language is required" $ langMeta s
     let pandoc = csContent s
     return (lang, pandoc)
 

src/Language.hs

@@ -1,23 +1,37 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language where
 
+import Control.Applicative
 import Control.Monad
 
+import Data.LanguageCodes
+import Data.List
 import Data.List.Split
 import qualified Data.Map as M
 import Data.Maybe
+import qualified Data.Yaml as Y
 
 
-type Language = String
+type Language = ISO639_1
 
 type LanguageMap = M.Map Language
 
-type LanguagePreference = LanguageMap Float
+mapKeysM :: (Monad m, Ord k1, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a)
+mapKeysM kfunc = liftM M.fromList . mapM kvfunc . M.toList
+    where kvfunc (k, v) = liftM (\k' -> (k', v)) $ kfunc k
+
+instance (Y.FromJSON v) => Y.FromJSON (M.Map Language v) where
+    parseJSON v = Y.parseJSON v >>= mapKeysM parseLanguage
+
+newtype LanguagePreference = LanguagePreference { unLanguagePreference :: LanguageMap Float }
+    deriving (Eq)
 
 defaultLanguage :: Language
-defaultLanguage = "en"
+defaultLanguage = EN
 
 rankLanguage :: Language -> LanguagePreference -> Float
-rankLanguage lang = fromMaybe 0 . M.lookup lang
+rankLanguage lang = fromMaybe 0 . M.lookup lang . unLanguagePreference
 
 matchLanguage :: LanguagePreference -> LanguageMap a -> Maybe a
 matchLanguage = matchLanguageFunc (const 1)
@@ -27,11 +41,24 @@ matchLanguageFunc quality pref values = liftM fst $ M.maxView ranked
     where ranked = M.fromList $ M.elems $ M.mapWithKey rank values
           rank lang value = (rankLanguage lang pref * quality value, value)
 
+parseLanguage :: MonadPlus m => String -> m Language
+parseLanguage [c1, c2] = case fromChars c1 c2 of
+                             Just lang -> return lang
+                             Nothing -> mzero
+parseLanguage _ = mzero
+
 -- TODO: Parsec or library
 languageHeader :: Maybe String -> LanguagePreference
-languageHeader Nothing = M.singleton defaultLanguage 1
-languageHeader (Just str) = M.fromList $ mapMaybe parsePref $ splitOn "," str
+languageHeader Nothing = LanguagePreference $ M.singleton defaultLanguage 1
+languageHeader (Just str) = LanguagePreference $ M.fromList $ mapMaybe parsePref $ splitOn "," str
     where parsePref pref = case splitOn ";q=" pref of
-                               [lang] -> Just (lang, 1)
-                               [lang, qvalue] -> Just (lang, read qvalue)
+                               [lang] -> (pairWith 1) <$> parseLanguage lang
+                               [lang, qvalue] -> (pairWith (read qvalue)) <$> parseLanguage lang
                                _ -> Nothing
+          pairWith y x = (x, y)
+
+instance Show LanguagePreference where
+    show = intercalate "," . map (uncurry showPref) . M.toList . unLanguagePreference
+        where showPref lang 1 = languageStr lang
+              showPref lang qvalue = languageStr lang ++ ";q=" ++ show qvalue
+              languageStr = (\(a, b) -> a:b:[]) . toChars

src/Main.hs

@@ -55,11 +55,13 @@ listenPort = liftM (read . fromMaybe "8000") (lookupEnv "LISTEN_PORT")
 -- Run the actual site
 runSite :: IO ()
 runSite = do
+    -- TODO: parametrise?
+    app <- loadApp "content"
     address <- siteAddress
     lport <- listenPort
     let conf = nullConf { port = lport }
     -- Manually bind the socket to close it on exception
     bracket
         (bindPort conf)
         close
-        (\sock -> simpleHTTPWithSocket' runApp sock conf $ siteHandler address)
+        (\sock -> simpleHTTPWithSocket' (runApp app) sock conf $ site address)

src/Models.hs

@@ -49,9 +49,10 @@ instance HasSlug Article where
 instance HasSlug Meta where
     getSlug = mtSlug
 
-data AppState = AppState { appArticles :: [Article]
-                         , appMeta     :: [Meta]
-                         , appStrings  :: M.Map String (LanguageMap String)
+data AppState = AppState { appDirectory :: String
+                         , appArticles  :: [Article]
+                         , appMeta      :: [Meta]
+                         , appStrings   :: M.Map String (LanguageMap String)
                          }
     deriving (Eq, Show)
 

testsuite/Integration/Base.hs

@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- Base functions for integration tests
+module Integration.Base where
+
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Monad.State
+
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.ByteString.UTF8 as U
+import Data.List
+import Data.List.Split
+import qualified Data.Map as M
+
+import Happstack.Server
+
+import Test.Framework
+import Test.HUnit
+
+import App
+import Import
+import Language
+
+
+-- Site handler with a test address
+testHandler :: ServerPartT App Response
+testHandler = site "http://test"
+
+-- Make a request to the application
+testRequest :: Request -> IO Response
+testRequest req = do
+    app <- loadApp "testsuite/Integration/content"
+    runApp app $ simpleHTTP'' testHandler req
+
+assertContains :: (Eq a, Show a) => [a] -> [a] -> Assertion
+assertContains needle haystack =
+    subAssert $ assertBoolVerbose
+        (show needle ++ " not found in:\n" ++ show haystack)
+        (needle `isInfixOf` haystack)
+
+-- Create a request with a specified URL
+-- Happstack doesn't make it easy
+mkRequest :: String -> IO Request
+mkRequest rPath = do
+    inputsBody <- newEmptyMVar
+    rBody <- newMVar (Body LB.empty)
+    return Request { rqSecure = False
+                   , rqMethod = GET
+                   , rqPaths = filter (/= "") $ splitOn "/" rPath
+                   , rqUri = rPath
+                   , rqQuery = ""
+                   , rqInputsQuery = []
+                   , rqInputsBody = inputsBody
+                   , rqCookies = []
+                   , rqVersion = HttpVersion 1 1
+                   , rqHeaders = M.empty
+                   , rqBody = rBody
+                   , rqPeer = ("", 0)
+                   }
+
+withLang :: LanguagePreference -> Request -> Request
+withLang lang req = req { rqHeaders = newHeaders }
+    where newHeaders = M.insert "accept-language" (HeaderPair "Accept-Language" [U.fromString pref]) (rqHeaders req)
+          pref = show lang
+
+-- Extract contents from a response
+responseContent :: Response -> IO String
+responseContent r@(Response _ _ _ _ _) = return $ U.toString $ LB.toStrict $ rsBody r
+responseContent f@(SendFile _ _ _ _ _ _ _) = do
+    contents <- readFile $ sfFilePath f
+    let offset = fromIntegral $ sfOffset f
+    let count = fromIntegral $ sfCount f
+    return $ drop offset $ take count contents

testsuite/Integration/TestArticle.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+
+module Integration.TestArticle where
+
+import Control.Monad
+
+import Data.LanguageCodes
+
+import Language
+
+import Integration.Base
+
+import Test.Framework
+
+
+test_article = do
+    req <- mkRequest "/2015/01/01/first-test"
+    article <- testRequest req
+    resp <- responseContent article
+    assertContains
+        "<h2 id=\"first-test-article\">First test article</h2>"
+        resp

testsuite/Integration/TestHome.hs

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+
+module Integration.TestHome where
+
+import Integration.Base
+
+import Test.Framework
+
+
+test_home = do
+    req <- mkRequest "/"
+    home <- testRequest req
+    resp <- responseContent home
+    assertContains "Test site" resp

testsuite/Integration/TestStatic.hs

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -F -pgmF htfpp #-}
+
+module Integration.TestStatic where
+
+import Control.Monad
+
+import Language
+
+import Integration.Base
+
+import Test.Framework
+
+
+test_static = do
+    req <- mkRequest "/some-verification-file.html"
+    static <- testRequest req
+    resp <- responseContent static
+    assertEqual
+        "This is the exact content of the verification file.\n"
+        resp

testsuite/Integration/content/2015-01-01-test-en.md

@@ -0,0 +1,9 @@
+---
+lang: en
+slug: first-test
+---
+
+First test article
+------------------
+
+Test content

testsuite/Integration/content/about-en.md

@@ -0,0 +1,9 @@
+---
+slug: about
+lang: en
+---
+
+Test About
+----------
+
+Integration test site

testsuite/Integration/content/static/some-verification-file.html

@@ -0,0 +1 @@
+This is the exact content of the verification file.

testsuite/Integration/content/strings.yaml

@@ -0,0 +1,7 @@
+home:
+  en: Home
+  ru: Главная
+  zh: 首页
+
+siteName:
+  en: Test site