diff --git a/multiblog.cabal b/multiblog.cabal index 51679ff..caec906 100644 --- a/multiblog.cabal +++ b/multiblog.cabal @@ -25,10 +25,13 @@ 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, @@ -36,6 +39,7 @@ Executable multiblog web-routes-happstack >= 0.23, web-routes-th >= 0.22, utf8-string >= 0.3, + unix >= 2.7, yaml >= 0.8, base >= 4.4 && < 5 diff --git a/src/App.hs b/src/App.hs index 9ea39c2..986e062 100644 --- a/src/App.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index a9e6946..ccb7163 100644 --- a/src/Main.hs +++ b/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)