Merge branch 'auto-cross-post'

README.md

@@ -69,10 +69,11 @@ Each entry has the following format:
 To obtain the authorization for cross-posting to a particular account on a
 service, run `multiblog authorize <service>`.
 
-To post all unposted articles to every configured service, run `multiblog
-crosspost`. An article is considered posted if a link to it or a _newer_ article
-is found in the external service account. Note that the `SITE_URL` must be set
-correctly so that the link in the cross post is valid.
+All new articles are cross-posted to every configured service when running the
+server. An article is considered already posted if a link to it or a _newer_
+article is found in the external service account. Note that the `SITE_URL` must
+be set correctly so that the link in the cross post is valid; articles are not
+posted if it is not set.
 
 The following services are supported:
 
@@ -179,5 +180,3 @@ An example of the analytics file, `content/analytics.yaml`:
 ```yaml
 google: UA-12345678-9
 ```
-
-[yaml-metadata]: http://johnmacfarlane.net/pandoc/demo/example9/pandocs-markdown.html#extension-yaml_metadata_block

multiblog.cabal

@@ -31,6 +31,7 @@ Executable multiblog
                , http-conduit
                , iso639
                , lens
+               , lifted-base
                , mtl
                , network
                , optparse-generic

src/App.hs

@@ -41,27 +41,32 @@ type AppPart a = RouteT Sitemap (ServerPartT App) a
 loadApp
     :: String -- directory to load from
     -> T.Text -- site address
+    -> Bool -- whether the address was explicitly specified
     -> IO AppData
-loadApp dataDirectory address = do
+loadApp dataDirectory address isRealAddress = do
     app <- loadFromDirectory dataDirectory
     case app of
         Left err -> error err
         Right appState ->
             return
                 appState
                 { appAddress = address
+                , appRealAddress = isRealAddress
                 }
 
-siteAddress :: IO T.Text
+-- | Application address, and whether it's specified explicitly
+siteAddress :: IO (T.Text, Bool)
 siteAddress = do
     addr <- fmap (fmap T.pack) $ lookupEnv "SITE_URL"
-    return $ fromMaybe "http://localhost:8000" addr
+    return $ case addr of
+        Just realAddr -> (realAddr, True)
+        Nothing -> ("http://localhost:8000", False)
 
 loadAppDefault :: IO AppData
 loadAppDefault = do
-    address <- siteAddress
+    (address, isRealAddress) <- siteAddress
     directory <- getCurrentDirectory
-    loadApp directory address
+    loadApp directory address isRealAddress
 
 initAppCache :: IO AppCache
 initAppCache = do

src/CrossPost.hs

@@ -1,5 +1,5 @@
 {-|
-Subcommand to cross-post the latest article to all external services.
+Action to cross-post the latest article to all external services.
 -}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -38,7 +38,9 @@ import Types.Services
 
 crossPost :: App ()
 crossPost = do
+    liftIO $ putStrLn $ "Cross-posting new articles..."
     runRoute $ crossPostTwitter
+    liftIO $ putStrLn $ "All new articles cross-posted."
 
 crossPostTwitter
     :: (MonadRoute m, URL m ~ Sitemap, MonadIO m, MonadReader AppData m)

src/Main.hs

@@ -9,14 +9,12 @@ import Options.Generic.Default
 
 import App
 import Authorize
-import CrossPost
 import ReloadHup
 import Serve
 
 data Args
     = Authorize String
-    | CrossPost
-    | Serve
+    | Main
     deriving (Generic)
 
 instance ParseRecord Args
@@ -27,8 +25,7 @@ main =
         app <- loadAppDefault
         cache <- initAppCache
         runApp cache app $ do
-            args <- liftIO $ getRecordDefault Serve "Multiblog"
+            args <- liftIO $ getRecordDefault Main "Multiblog"
             case args of
                 Authorize service -> authorize service
-                CrossPost -> crossPost
-                Serve -> serve
+                Main -> crossPostAndServe

src/Models.hs

@@ -39,6 +39,7 @@ instance FromJSON Analytics where
 data AppData = AppData
     { appDirectory :: String
     , appAddress :: T.Text
+    , appRealAddress :: Bool
     , appArticles :: [Article]
     , appMeta :: [Meta]
     , appStrings :: M.Map String LanguageString
@@ -53,6 +54,7 @@ instance Default AppData where
         AppData
         { appDirectory = def
         , appAddress = T.empty
+        , appRealAddress = False
         , appArticles = def
         , appMeta = def
         , appStrings = def

src/Serve.hs

@@ -1,9 +1,9 @@
 {-|
-Command to serve the blog.
+Action to serve the blog.
 -}
 module Serve where
 
-import Control.Monad.IO.Class
+import Control.Concurrent.Lifted
 import Control.Exception
 import Control.Monad
 import Control.Monad.Reader
@@ -18,11 +18,22 @@ import Network.Socket
 import System.Environment
 
 import App
+import Models
+import CrossPost
+
+
+crossPostAndServe :: App ()
+crossPostAndServe = do
+    isRealAddress <- asks appRealAddress
+    when isRealAddress $ do
+        void $ fork crossPost
+    serve
 
 -- Serve the site contents, handling SIGHUP
 serve :: App ()
 serve = do
     lport <- liftIO listenPort
+    liftIO $ putStrLn $ "Serving on port " ++ show lport ++ "."
     let conf =
             nullConf
             { port = lport

testsuite/Integration/Base.hs

@@ -49,7 +49,7 @@ testAddress = "http://test"
 makeRequest :: TestRequest -> IO String
 makeRequest req = do
     happstackReq <- mkRequest req
-    app <- loadApp "testsuite/Integration/content" testAddress
+    app <- loadApp "testsuite/Integration/content" testAddress False
     cache <- initAppCache
     rsp <- runApp cache app $ simpleHTTP'' site happstackReq
     content <- responseContent rsp