Merge branch 'signals'

Author: koterpillar

multiblog.cabal

@@ -25,17 +25,21 @@ Executable multiblog
     happstack >= 7.0,
     happstack-server >= 7.3,
     mtl >= 2.1 && < 2.3,
+    network >= 2.6,
     pandoc >= 1.13,
     pandoc-types >= 1.12,
     shakespeare >= 2.0,
     split >= 0.2,
+    system-argv0 >= 0.1,
+    system-filepath >= 0.4,
     text >= 1.1,
     time >= 1.4 && < 1.6,
     web-routes >= 0.27,
     web-routes-boomerang >= 0.26,
     web-routes-happstack >= 0.23,
     web-routes-th >= 0.22,
     utf8-string >= 0.3,
+    unix >= 2.7,
     yaml >= 0.8,
     base >= 4.4 && < 5
 

src/App.hs

@@ -1,13 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
 module App where
 
 import Control.Monad.State
 
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Text as T
+import Data.Time
+
+import Happstack.Server
+
+import Web.Routes
+import Web.Routes.Boomerang
+import Web.Routes.Happstack
+
 import Import
+import Language
 import Models
+import Routes
+import Utils
+import Views
 
 
 type App = StateT AppState IO
 
+type AppPart a = RouteT Sitemap (ServerPartT App) a
+
 runApp :: App a -> IO a
 runApp a = do
     loaded <- loadFromDirectory "content"
@@ -16,3 +33,57 @@ runApp a = do
         Right appState -> do
             print appState
             evalStateT a appState
+
+site :: Site Sitemap (ServerPartT App Response)
+site = boomerangSiteRouteT handler sitemap
+
+siteHandler :: String -> ServerPartT App Response
+siteHandler address = implSite (T.pack address) "" site
+
+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 -> meta s
+
+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 date = articleList $ byDate date
+
+languageHeaderM :: AppPart LanguagePreference
+languageHeaderM = do
+    request <- askRq
+    let header = getHeader "Accept-Language" request
+    return $ languageHeader $ liftM B.unpack header
+
+html :: ToMessage a => a -> AppPart Response
+html = ok . toResponse
+
+article :: Day -> String -> AppPart Response
+article date slug = do
+    language <- languageHeaderM
+    a <- onlyOne $ lift $ getFiltered $ byDateSlug date slug
+    articleDisplay language a >>= html
+
+articleList :: (Article -> Bool) -> AppPart Response
+articleList articleFilter = do
+    articles <- lift $ getFiltered articleFilter
+    language <- languageHeaderM
+    articleListDisplay language articles >>= html
+
+meta :: String -> AppPart Response
+meta slug = do
+    language <- languageHeaderM
+    m <- getMeta slug
+    metaDisplay language m >>= html

src/Main.hs

@@ -1,92 +1,65 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators     #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeOperators      #-}
 module Main where
 
+import Control.Concurrent
+import Control.Exception
 import Control.Monad
-import Control.Monad.State
 
-import qualified Data.ByteString.Char8 as B
 import Data.Maybe
-import qualified Data.Text as T
-import Data.Time
+import Data.Typeable
+
+import Filesystem.Path.CurrentOS
 
 import Happstack.Server
 
-import System.Environment
+import Network.Socket
 
-import Web.Routes
-import Web.Routes.Boomerang
-import Web.Routes.Happstack
+import System.Argv0
+import System.Environment
+import System.Posix.Process
+import System.Posix.Signals
 
 import App
-import Language
-import Models
-import Routes
-import Utils
-import Views
 
-type AppPart a = RouteT Sitemap (ServerPartT App) a
+data Reload = Reload
+    deriving (Show, Typeable)
 
-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 -> meta s
+instance Exception Reload
 
-site :: Site Sitemap (ServerPartT App Response)
-site = boomerangSiteRouteT handler sitemap
+-- Run the site, handling SIGHUP
+main :: IO ()
+main = do
+    mainThread <- myThreadId
+    _ <- installHandler lostConnection
+        (CatchOnce $ reloadExecutable mainThread) Nothing
+    runSite
+
+-- Replace the process with a (possibly updated) executable
+-- Throw a "Reload" exception to the main thread so it releases
+-- its socket first
+reloadExecutable :: ThreadId -> IO ()
+reloadExecutable mainThread = do
+    throwTo mainThread Reload
+    ownPath <- liftM encodeString getArgv0
+    executeFile ownPath False [] Nothing
 
 siteAddress :: IO String
 siteAddress = do
     addr <- lookupEnv "SITE_URL"
     return $ fromMaybe "http://localhost:8000" addr
 
-main :: IO ()
-main = do
-    address <- siteAddress
-    listenPort <- lookupEnv "LISTEN_PORT"
-    let conf = nullConf { port = read $ fromMaybe "8000" listenPort }
-    simpleHTTP' runApp conf $ implSite (T.pack address) "" site
-
-index :: AppPart Response
-index = articleList $ const True
+listenPort :: IO Int
+listenPort = liftM (read . fromMaybe "8000") (lookupEnv "LISTEN_PORT")
 
-yearlyIndex :: Integer -> AppPart Response
-yearlyIndex = articleList . byYear
-
-monthlyIndex :: Integer -> Int -> AppPart Response
-monthlyIndex year month = articleList $ byYearMonth year month
-
-dailyIndex :: Day -> AppPart Response
-dailyIndex date = articleList $ byDate date
-
-languageHeaderM :: AppPart LanguagePreference
-languageHeaderM = do
-    request <- askRq
-    let header = getHeader "Accept-Language" request
-    return $ languageHeader $ liftM B.unpack header
-
-html :: ToMessage a => a -> AppPart Response
-html = ok . toResponse
-
-article :: Day -> String -> AppPart Response
-article date slug = do
-    language <- languageHeaderM
-    -- TODO: onlyOne
-    a <- onlyOne $ lift $ getFiltered $ byDateSlug date slug
-    articleDisplay language a >>= html
-
-articleList :: (Article -> Bool) -> AppPart Response
-articleList articleFilter = do
-    articles <- lift $ getFiltered articleFilter
-    language <- languageHeaderM
-    articleListDisplay language articles >>= html
-
-meta :: String -> AppPart Response
-meta slug = do
-    language <- languageHeaderM
-    m <- getMeta slug
-    metaDisplay language m >>= html
+-- Run the actual site
+runSite :: IO ()
+runSite = do
+    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)