diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ +Copyright (c) 2015 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,7 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff --git a/app/servius.hs b/app/servius.hs new file mode 100644 --- /dev/null +++ b/app/servius.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Blaze.ByteString.Builder.Char.Utf8 (fromLazyText) +import qualified Data.ByteString.Char8 as S8 +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as TL +import Network.HTTP.Types (status200) +import Network.Wai (Middleware, Response, + pathInfo, responseBuilder) +import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) +import Text.Hamlet (defaultHamletSettings) +import Text.Hamlet.RT (parseHamletRT, + renderHamletRT) +import Text.Lucius (luciusRT) +import Text.Markdown (def, msXssProtect, msAddHeadingId, markdown) +import WaiAppStatic.CmdLine (docroot, runCommandLine) + +main :: IO () +main = runCommandLine (shake . docroot) + +shake :: FilePath -> Middleware +shake docroot app req respond + | any unsafe p = app req respond + | null p = app req respond + | ".hamlet" `T.isSuffixOf` l = hamlet pr >>= respond + | ".lucius" `T.isSuffixOf` l = lucius pr >>= respond + | ".markdown" `T.isSuffixOf` l = markdown' pr >>= respond + | ".md" `T.isSuffixOf` l = markdown' pr >>= respond + | otherwise = app req respond + where + p = pathInfo req + pr = T.intercalate "/" $ T.pack docroot : p + l = last p + +unsafe :: Text -> Bool +unsafe s + | T.null s = False + | T.head s == '.' = True + | otherwise = T.any (== '/') s + +readFileUtf8 :: Text -> IO String +readFileUtf8 fp = do + bs <- S8.readFile $ T.unpack fp + let t = decodeUtf8With lenientDecode bs + return $ T.unpack t + +hamlet :: Text -> IO Response +hamlet fp = do + str <- readFileUtf8 fp + hrt <- parseHamletRT defaultHamletSettings str + html <- renderHamletRT hrt [] (error "No URLs allowed") + return $ responseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ renderHtmlBuilder html + +lucius :: Text -> IO Response +lucius fp = do + str <- readFileUtf8 fp + let text = either error id $ luciusRT (TL.pack str) [] + return $ responseBuilder status200 [("Content-Type", "text/css; charset=utf-8")] $ fromLazyText text + +markdown' :: Text -> IO Response +markdown' fp = do + bs <- S8.readFile $ T.unpack fp + let t = decodeUtf8With lenientDecode bs + html = markdown settings $ TL.fromStrict t + return $ responseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ renderHtmlBuilder html + where + settings = def + { msXssProtect = False + , msAddHeadingId = True + } diff --git a/servius.cabal b/servius.cabal --- a/servius.cabal +++ b/servius.cabal @@ -1,37 +1,36 @@ -Name: servius -Version: 1.1.1.2 -Synopsis: Serve Shakespearean templates via Warp (deprecated) -Homepage: http://github.com/yesodweb/hamlet -License: MIT -License-file: LICENSE -Author: Michael Snoyman -Maintainer: michael@snoyman.com -Category: Web -Build-type: Simple -Cabal-version: >=1.6 -Description: Does not support any variable interpolation. Supports Hamlet and Lucius files (must have .hamlet and .lucius file extensions, respectively). +name: servius +version: 1.2.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2015 Michael Snoyman +maintainer: michael@snoyman.com +homepage: http://github.com/snoyberg/servius#readme +synopsis: Warp web server with template rendering +description: + Please see README.md +category: Web +author: Michael Snoyman +source-repository head + type: git + location: https://github.com/snoyberg/servius -Executable servius - Main-is: servius.hs - Build-depends: base >= 4 && < 5 - , warp >= 1.3 && < 2.2 - , wai-app-static >= 1.3 && < 2.1 - , wai-extra >= 1.3 && < 2.2 - , cmdargs >= 0.6.7 - , directory >= 1.0 - , containers >= 0.2 - , bytestring >= 0.9.1.4 - , text >= 0.7 - , blaze-builder - , blaze-html >= 0.5 - , http-types - , hamlet >= 1.1 && < 1.2 - , shakespeare-css >= 1.0 && < 1.1 - , transformers - , wai >= 1.3 && < 2.2 - , mime-types >= 0.1 && < 0.2 +executable servius + main-is: servius.hs + build-depends: + base >=4.8.1.0 && <4.9, + blaze-builder >=0.4.0.1 && <0.5, + blaze-html >=0.8.1.1 && <0.9, + bytestring >=0.10.6.0 && <0.11, + http-types >=0.8.6 && <0.9, + markdown >=0.1.13.2 && <0.2, + shakespeare >=2.0.6 && <2.1, + text >=1.2.1.3 && <1.3, + wai >=3.0.4.0 && <3.1, + wai-app-static >=3.1.1 && <3.2 + default-language: Haskell2010 + hs-source-dirs: app + ghc-options: -threaded -rtsopts -with-rtsopts=-N -source-repository head - type: git - location: git://github.com/yesodweb/shakespeare.git diff --git a/servius.hs b/servius.hs deleted file mode 100644 --- a/servius.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -import Network.Wai.Application.Static (staticApp, defaultFileServerSettings) -import Network.Wai.Handler.Warp (run) -import System.Console.CmdArgs hiding (def) -import Text.Printf (printf) -import System.Directory (canonicalizePath) -import Control.Monad (unless) -import Network.Wai.Middleware.Autohead -import Network.Wai.Middleware.RequestLogger -import Network.Wai.Middleware.Gzip -import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as S8 -import Control.Arrow ((***)) -import Data.Text (Text, pack) -import qualified Data.Text as T -import Network.Wai -import Control.Monad.IO.Class (liftIO) -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Text.Lucius (luciusRT) -import Text.Hamlet (defaultHamletSettings) -import Text.Hamlet.RT (parseHamletRT, renderHamletRT) -import Network.HTTP.Types (status200) -import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder) -import qualified Data.Text.Lazy as TL -import Blaze.ByteString.Builder.Char.Utf8 (fromLazyText) -import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType) -import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece) -import Data.String (fromString) -import Data.Maybe (mapMaybe) - -data Args = Args - { docroot :: FilePath - , index :: [FilePath] - , port :: Int - , noindex :: Bool - , quiet :: Bool - , verbose :: Bool - , mime :: [(String, String)] - } - deriving (Show, Data, Typeable) - -defaultArgs :: Args -defaultArgs = Args "." ["index.html", "index.htm"] 3000 False False False [] - -main :: IO () -main = do - Args {..} <- cmdArgs defaultArgs - let mime' = map (pack *** S8.pack) mime - let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap - docroot' <- canonicalizePath docroot - unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index) - let middle = gzip def - . (if verbose then logStdoutDev else id) - . autohead - . shake docroot - run port $ middle $ staticApp (defaultFileServerSettings $ fromString docroot) - { ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index - , ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName - } - -shake :: FilePath -> Middleware -shake docroot app req - | any unsafe p = app req - | null p = app req - | ".hamlet" `T.isSuffixOf` l = liftIO $ hamlet pr - | ".lucius" `T.isSuffixOf` l = liftIO $ lucius pr - | otherwise = app req - where - p = pathInfo req - pr = T.intercalate "/" $ T.pack docroot : p - l = last p - -unsafe :: Text -> Bool -unsafe s - | T.null s = False - | T.head s == '.' = True - | otherwise = T.any (== '/') s - -readFileUtf8 :: Text -> IO String -readFileUtf8 fp = do - bs <- S8.readFile $ T.unpack fp - let t = decodeUtf8With lenientDecode bs - return $ T.unpack t - -#if MIN_VERSION_wai(2, 0, 0) -#define ResponseBuilder responseBuilder -#endif - -hamlet :: Text -> IO Response -hamlet fp = do - str <- readFileUtf8 fp - hrt <- parseHamletRT defaultHamletSettings str - html <- renderHamletRT hrt [] (error "No URLs allowed") - return $ ResponseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ renderHtmlBuilder html - -lucius :: Text -> IO Response -lucius fp = do - str <- readFileUtf8 fp - let text = either error id $ luciusRT (TL.pack str) [] - return $ ResponseBuilder status200 [("Content-Type", "text/css; charset=utf-8")] $ fromLazyText text