diff --git a/multiblog.cabal b/multiblog.cabal index caec906..aba4a0e 100644 --- a/multiblog.cabal +++ b/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 diff --git a/src/App.hs b/src/App.hs index 986e062..b7c59b3 100644 --- a/src/App.hs +++ b/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 diff --git a/src/Import.hs b/src/Import.hs index 9fbd9c3..e939f61 100644 --- a/src/Import.hs +++ b/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) diff --git a/src/Language.hs b/src/Language.hs index e968f4b..cb97d53 100644 --- a/src/Language.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index ccb7163..9bceed5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -55,6 +55,8 @@ 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 } @@ -62,4 +64,4 @@ runSite = do bracket (bindPort conf) close - (\sock -> simpleHTTPWithSocket' runApp sock conf $ siteHandler address) + (\sock -> simpleHTTPWithSocket' (runApp app) sock conf $ site address) diff --git a/src/Models.hs b/src/Models.hs index be2fc93..df338aa 100644 --- a/src/Models.hs +++ b/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) diff --git a/testsuite/Integration/Base.hs b/testsuite/Integration/Base.hs new file mode 100644 index 0000000..4540f4f --- /dev/null +++ b/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 diff --git a/testsuite/Integration/TestArticle.hs b/testsuite/Integration/TestArticle.hs new file mode 100644 index 0000000..13f9d18 --- /dev/null +++ b/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 + "

First test article

" + resp diff --git a/testsuite/Integration/TestHome.hs b/testsuite/Integration/TestHome.hs new file mode 100644 index 0000000..65ca95d --- /dev/null +++ b/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 diff --git a/testsuite/Integration/TestStatic.hs b/testsuite/Integration/TestStatic.hs new file mode 100644 index 0000000..6a6693e --- /dev/null +++ b/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 diff --git a/testsuite/Integration/content/2015-01-01-test-en.md b/testsuite/Integration/content/2015-01-01-test-en.md new file mode 100644 index 0000000..559c237 --- /dev/null +++ b/testsuite/Integration/content/2015-01-01-test-en.md @@ -0,0 +1,9 @@ +--- +lang: en +slug: first-test +--- + +First test article +------------------ + +Test content diff --git a/testsuite/Integration/content/about-en.md b/testsuite/Integration/content/about-en.md new file mode 100644 index 0000000..5473e77 --- /dev/null +++ b/testsuite/Integration/content/about-en.md @@ -0,0 +1,9 @@ +--- +slug: about +lang: en +--- + +Test About +---------- + +Integration test site diff --git a/testsuite/Integration/content/static/some-verification-file.html b/testsuite/Integration/content/static/some-verification-file.html new file mode 100644 index 0000000..4fc7ac0 --- /dev/null +++ b/testsuite/Integration/content/static/some-verification-file.html @@ -0,0 +1 @@ +This is the exact content of the verification file. diff --git a/testsuite/Integration/content/strings.yaml b/testsuite/Integration/content/strings.yaml new file mode 100644 index 0000000..74d6819 --- /dev/null +++ b/testsuite/Integration/content/strings.yaml @@ -0,0 +1,7 @@ +home: + en: Home + ru: Главная + zh: 首页 + +siteName: + en: Test site diff --git a/testsuite/TestImport.hs b/testsuite/TestImport.hs index 3a9630f..49d1a8f 100644 --- a/testsuite/TestImport.hs +++ b/testsuite/TestImport.hs @@ -6,6 +6,7 @@ module TestImport where import Control.Monad import qualified Data.ByteString.Char8 as C8 +import Data.LanguageCodes import Data.List import qualified Data.Map as M import Data.Text (pack) @@ -42,7 +43,7 @@ modifyAppState f st = st { appArticles = map f $ appArticles st } nullState :: AppState -nullState = AppState [] [] (M.empty) +nullState = AppState "" [] [] (M.empty) testSource :: FilePath -> [(String, String)] -> String -> ContentSource testSource path meta content = ContentSource path $ readMarkdown def $ markdown meta content @@ -52,7 +53,7 @@ test_loadMeta = do ] assertEqual (Right $ nullState { appMeta = [ Meta { mtSlug = "about" - , mtContent = M.fromList [ ("en", readMarkdown def "This is meta") + , mtContent = M.fromList [ (EN, readMarkdown def "This is meta") ] } ] @@ -71,8 +72,8 @@ test_loadStrings = do ] assertEqual (loadStrings strings) - (Right $ M.fromList [ ("title", M.fromList [("en", "Title"), ("ru", "Заголовок")]) - , ("about", M.fromList [("zh", "关于")]) + (Right $ M.fromList [ ("title", M.fromList [(EN, "Title"), (RU, "Заголовок")]) + , ("about", M.fromList [(ZH, "关于")]) ]) sort2 :: Ord a => [[a]] -> [[a]] diff --git a/testsuite/TestLanguage.hs b/testsuite/TestLanguage.hs index 2c4370c..887f7a7 100644 --- a/testsuite/TestLanguage.hs +++ b/testsuite/TestLanguage.hs @@ -1,7 +1,14 @@ {-# OPTIONS_GHC -F -pgmF htfpp #-} +{-# LANGUAGE TemplateHaskell #-} module TestLanguage where +import Prelude hiding (LT) + +import Control.Applicative + +import Data.DeriveTH +import Data.LanguageCodes import qualified Data.Map as M import Language @@ -9,28 +16,42 @@ import Language import Test.Framework +mkPreference :: [(Language, Float)] -> LanguagePreference +mkPreference = LanguagePreference . M.fromList + + test_matchLanguageFunc = do - let values = M.fromList [ ("en", "English") - , ("ru", "Russian") - , ("zh", "Chinese") + let values = M.fromList [ (EN, "English") + , (RU, "Russian") + , (ZH, "Chinese") ] assertEqual (Nothing :: Maybe String) - (matchLanguage (M.fromList [("ru", 1)]) M.empty) + (matchLanguage (mkPreference [(RU, 1)]) M.empty) assertEqual (Just "Russian") - (matchLanguage (M.fromList [("ru", 1)]) values) + (matchLanguage (mkPreference [(RU, 1)]) values) test_languageHeader = do assertEqual (languageHeader Nothing) - (M.fromList [("en", 1)]) + (mkPreference [(EN, 1)]) assertEqual (languageHeader $ Just "fr") - (M.fromList [("fr", 1)]) + (mkPreference [(FR, 1)]) assertEqual (languageHeader $ Just "de,fr,ko") - (M.fromList [("de", 1), ("fr", 1), ("ko", 1)]) + (mkPreference [(DE, 1), (FR, 1), (KO, 1)]) assertEqual (languageHeader $ Just "ru,zh;q=0.8,en;q=0.6") - (M.fromList [("ru", 1), ("zh", 0.8), ("en", 0.6)]) + (mkPreference [(RU, 1), (ZH, 0.8), (EN, 0.6)]) + +derive makeArbitrary ''ISO639_1 + +instance Arbitrary LanguagePreference where + arbitrary = mkPreference <$> arbitrary + +prop_showLanguageHeader m = languageHeader (Just (show m)) == m + +prop_mapKeysM :: [(String, String)] -> Bool +prop_mapKeysM l = mapKeysM Just m == Just m where m = M.fromList l diff --git a/testsuite/TestMain.hs b/testsuite/TestMain.hs index b1566fd..0c0e78d 100644 --- a/testsuite/TestMain.hs +++ b/testsuite/TestMain.hs @@ -2,6 +2,9 @@ import Test.Framework +import {-@ HTF_TESTS @-} Integration.TestArticle +import {-@ HTF_TESTS @-} Integration.TestHome +import {-@ HTF_TESTS @-} Integration.TestStatic import {-@ HTF_TESTS @-} TestImport import {-@ HTF_TESTS @-} TestLanguage import {-@ HTF_TESTS @-} TestUtils