Improve path-handling and add public-by-default option
Getty Ritter
7 years ago
| 8 | 8 | import Data.Monoid ((<>)) |
| 9 | 9 | import qualified Data.Time.Clock as Time |
| 10 | 10 | import qualified Data.Time.Format as Time |
| 11 | import qualified Data.Text as T | |
| 12 | import qualified Data.Text.Encoding as T | |
| 11 | 13 | import qualified Network.Gitit.Config as Gitit |
| 12 | 14 | import qualified Network.Gitit.Page as Gitit |
| 13 | 15 | import qualified Network.Gitit.Types as Gitit |
| 22 | 24 | import qualified Text.Pandoc as Pandoc |
| 23 | 25 | import Text.Printf (printf) |
| 24 | 26 | |
| 27 | data Protection | |
| 28 | = PrivateByDefault | |
| 29 | | PublicByDefault | |
| 30 | deriving (Eq, Show) | |
| 31 | ||
| 25 | 32 | data FrontitOpts = FrontitOpts |
| 26 | 33 | { optPort :: Int |
| 27 | 34 | , optData :: Maybe FilePath |
| 28 | 35 | , optGititConfig :: Maybe FilePath |
| 29 | 36 | , optTemplate :: Maybe FilePath |
| 37 | , optProtection :: Protection | |
| 30 | 38 | } deriving (Eq, Show) |
| 31 | 39 | |
| 32 | 40 | defaultOpts :: FrontitOpts |
| 35 | 43 | , optData = Nothing |
| 36 | 44 | , optGititConfig = Nothing |
| 37 | 45 | , optTemplate = Nothing |
| 46 | , optProtection = PrivateByDefault | |
| 38 | 47 | } |
| 39 | 48 | |
| 40 | 49 | frontitOptDescr :: [Opt.OptDescr (FrontitOpts -> FrontitOpts)] |
| 51 | 60 | , Opt.Option ['t'] ["template"] |
| 52 | 61 | (Opt.ReqArg (\ s opts -> opts { optTemplate = Just s }) "path") |
| 53 | 62 | "The location of the desired HTML template" |
| 63 | , Opt.Option ['o'] ["public-by-default"] | |
| 64 | (Opt.NoArg (\ opts -> opts { optProtection = PublicByDefault})) | |
| 65 | "Allow all pages to be browsed by default" | |
| 54 | 66 | ] |
| 55 | 67 | |
| 56 | 68 | optsToConfiguration :: FrontitOpts -> IO FrontitConf |
| 64 | 76 | fcGititConfig <- case optGititConfig of |
| 65 | 77 | Just path -> Gitit.getConfigFromFile path |
| 66 | 78 | Nothing -> Gitit.getDefaultConfig |
| 79 | let fcProtection = optProtection | |
| 67 | 80 | return FrontitConf { .. } |
| 68 | 81 | |
| 69 | 82 | defaultTemplate :: String |
| 73 | 86 | { fcData :: FilePath |
| 74 | 87 | , fcGititConfig :: Gitit.Config |
| 75 | 88 | , fcTemplate :: String |
| 89 | , fcProtection :: Protection | |
| 76 | 90 | } |
| 77 | 91 | |
| 78 | 92 | data Result |
| 90 | 104 | rawPage <- readFile localPath |
| 91 | 105 | let pg = Gitit.stringToPage (fcGititConfig conf) path rawPage |
| 92 | 106 | case lookup "public" (Gitit.pageMeta pg) of |
| 93 | Just "yes" -> return (Found pg) | |
| 94 | _ -> return Private | |
| 107 | Just "yes" | fcProtection conf == PrivateByDefault -> return (Found pg) | |
| 108 | Just "no" | fcProtection conf == PublicByDefault -> return Private | |
| 109 | _ | fcProtection conf == PublicByDefault -> return (Found pg) | |
| 110 | | otherwise -> return Private | |
| 95 | 111 | |
| 96 | 112 | convertLinks :: Pandoc.Inline -> Pandoc.Inline |
| 97 | 113 | convertLinks link@(Pandoc.Link as name ("",title)) = |
| 126 | 142 | Gitit.DocBook -> Pandoc.readDocBook def pageText |
| 127 | 143 | Gitit.MediaWiki -> Pandoc.readMediaWiki def pageText |
| 128 | 144 | |
| 129 |
getLocalPath :: FrontitConf -> |
|
| 145 | getLocalPath :: FrontitConf -> T.Text -> Maybe FilePath | |
| 130 | 146 | getLocalPath conf req |
| 131 | | BS.any (== '.') req = Nothing | |
| 132 | | req == "/" = Just (Gitit.frontPage (fcGititConfig conf) <> ".page") | |
| 133 |
| |
|
| 147 | | T.any (== '.') req = Nothing | |
| 148 | | req == "" = Just (Gitit.frontPage (fcGititConfig conf) <> ".page") | |
| 149 | | otherwise = Just (T.unpack (req <> ".page")) | |
| 134 | 150 | |
| 135 | 151 | app :: FrontitConf -> Wai.Application |
| 136 | 152 | app conf = \ req respond -> do |
| 137 |
let respond' st pg = respond (Wai.responseLBS st [] (LBS. |
|
| 153 | let respond' st pg = respond (Wai.responseLBS st [] (LBS.fromStrict (T.encodeUtf8 (T.pack pg)))) | |
| 138 | 154 | if Wai.requestMethod req == "GET" |
| 139 | 155 | then do |
| 140 |
case getLocalPath conf ( |
|
| 156 | case getLocalPath conf (T.intercalate ("/") (Wai.pathInfo req)) of | |
| 141 | 157 | Nothing -> respond' Http.status403 "invalid URL" |
| 142 | 158 | Just path -> do |
| 143 | 159 | result <- fetchPage conf path |