8ae58c7
eaaf023
8ae58c7
4e98f6d
b42ebd1
8ae58c7
5d4cb39
8ae58c7
4e98f6d
8ae58c7
eaaf023
8ae58c7
5d4cb39
8ae58c7
b42ebd1
8ae58c7
4e98f6d
eaaf023
8ae58c7
4e98f6d
8ae58c7
4e98f6d
8ae58c7
b42ebd1
cde8760
b42ebd1
8ae58c7
eaaf023
8ae58c7
eaaf023
4e98f6d
b42ebd1
4e98f6d
eaaf023
4e98f6d
eaaf023
4e98f6d
8ae58c7
eaaf023
|
| {-# LANGUAGE RecordWildCards #-}
module Main where
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Default (def)
import qualified Data.Map.Strict as Map
import Data.Monoid ((<>))
import qualified Data.Time.Clock as Time
import qualified Data.Time.Format as Time
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Gitit.Page as Gitit
import qualified Network.Gitit.Types as Gitit
import qualified Network.HTTP.Types.Status as Http
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified System.Directory as Dir
import System.FilePath ((</>), makeRelative)
import qualified Text.Pandoc as Pandoc
import Text.Printf (printf)
import Config
data Result
= Found Gitit.Page
| Private
| NotFound
fetchPage :: FrontitConf -> FilePath -> IO Result
fetchPage conf path = do
let localPath = fcData conf </> (makeRelative "/" path)
exists <- Dir.doesFileExist localPath
if not exists
then return NotFound
else do
rawPage <- readFile localPath
let pg = Gitit.stringToPage (fcGititConfig conf) path rawPage
case lookup "public" (Gitit.pageMeta pg) of
Just "yes" | fcProtection conf == PrivateByDefault -> return (Found pg)
Just "no" | fcProtection conf == PublicByDefault -> return Private
_ | fcProtection conf == PublicByDefault -> return (Found pg)
| otherwise -> return Private
convertLinks :: Pandoc.Inline -> Pandoc.Inline
convertLinks link@(Pandoc.Link as name ("",title)) =
case flatten name of
Nothing -> link
Just text -> Pandoc.Link as name (text, title)
convertLinks rs = rs
flatten :: [Pandoc.Inline] -> Maybe String
flatten = fmap mconcat . sequence . fmap go
where go (Pandoc.Str s) = Just s
go Pandoc.Space = Just " "
go _ = Nothing
addTitle :: T.Text -> Pandoc.Pandoc -> Pandoc.Pandoc
addTitle title p@(Pandoc.Pandoc meta@(Pandoc.Meta metaMap) bs)
| Just _ <- Pandoc.lookupMeta "title" meta = p
| otherwise = Pandoc.Pandoc newMeta bs
where titleVal = Pandoc.MetaString (T.unpack title)
newMeta = Pandoc.Meta (Map.insert "title" titleVal metaMap)
renderPage :: FrontitConf -> Gitit.Page -> T.Text -> String
renderPage conf pg@Gitit.Page { .. } title =
Pandoc.writeHtmlString writerOpts (addTitle title pandoc)
where
writerOpts = def { Pandoc.writerTemplate = fcTemplate conf
, Pandoc.writerStandalone = True
}
rawPage = Gitit.pageToString (fcGititConfig conf) pg
pandoc = Pandoc.bottomUp convertLinks (Pandoc.handleError parsed)
parsed =
case pageFormat of
Gitit.Markdown -> Pandoc.readMarkdown def rawPage
Gitit.CommonMark -> Pandoc.readCommonMark def rawPage
Gitit.RST -> Pandoc.readRST def pageText
Gitit.LaTeX -> Pandoc.readLaTeX def pageText
Gitit.HTML -> Pandoc.readHtml def pageText
Gitit.Textile -> Pandoc.readTextile def pageText
Gitit.Org -> Pandoc.readOrg def pageText
Gitit.DocBook -> Pandoc.readDocBook def pageText
Gitit.MediaWiki -> Pandoc.readMediaWiki def pageText
getLocalPath :: FrontitConf -> T.Text -> Maybe FilePath
getLocalPath conf req
| T.any (== '.') req = Nothing
| req == "" = Just (Gitit.frontPage (fcGititConfig conf) <> ".page")
| otherwise = Just (T.unpack (req <> ".page"))
getTitle :: FrontitConf -> [T.Text] -> T.Text
getTitle conf [] = T.pack (Gitit.frontPage (fcGititConfig conf))
getTitle _ cs = T.toTitle (last cs)
strToByteString :: String -> LBS.ByteString
strToByteString = LBS.fromStrict . T.encodeUtf8 . T.pack
-- Our application is simple: every GET request will look up a
-- corresponding file in the data directory and serve it according
-- to roughly the same logic as Gitit.
app :: FrontitConf -> Wai.Application
app conf = \ req respond -> do
let respond' st pg = respond (Wai.responseLBS st [] (strToByteString pg))
if Wai.requestMethod req == "GET"
then do
case getLocalPath conf (T.intercalate ("/") (Wai.pathInfo req)) of
Nothing -> respond' Http.status403 "invalid URL"
Just path -> do
let title = getTitle conf (Wai.pathInfo req)
result <- fetchPage conf path
case result of
Found pg -> respond' Http.status200 (renderPage conf pg title)
Private -> respond' Http.status403 "private page"
NotFound -> respond' Http.status404 "not found"
else respond' Http.status403 "forbidden"
-- Something like this exists in wai-extra, but I don't want to have
-- to depend on an even bigger set of deps after gitit+pandoc, so
-- this is a quick reimplementation.
mkLogger :: Wai.Application -> Wai.Application
mkLogger app' = \ req respond -> app' req $ \ resp -> do
currentTime <- Time.getCurrentTime
let time = Time.formatTime
Time.defaultTimeLocale
"[%d/%b/%Y:%H:%M:%S %z]"
currentTime
printf "%v - - %v \"%v %v %v\" %v -\n"
(show (Wai.remoteHost req))
time
(BS.unpack (Wai.requestMethod req))
(BS.unpack (Wai.rawPathInfo req))
(show (Wai.httpVersion req))
(Http.statusCode (Wai.responseStatus resp))
respond resp
main :: IO ()
main = do
conf <- getConfig
printf "running frontit on port %d\n" (fcPort conf)
Warp.run (fcPort conf) (mkLogger (app conf))
|
|