gitit 0.12.3.2 → 0.13.0.0
raw patch · 10 files changed
+240/−118 lines, 10 filesdep +doctemplatesdep +network-bsddep +xml-typesdep ~ConfigFiledep ~HTTPdep ~SHAPVP ok
version bump matches the API change (PVP)
Dependencies added: doctemplates, network-bsd, xml-types
Dependency ranges changed: ConfigFile, HTTP, SHA, base64-bytestring, feed, filestore, happstack-server, hoauth2, hslogger, json, network, network-uri, old-locale, pandoc, pandoc-types, skylighting, time, uri-bytestring, url, xml-conduit
API changes (from Hackage documentation)
- Network.Gitit.Rpxnow: authenticate :: Monad m => String -> String -> IO (m Identifier)
+ Network.Gitit.Rpxnow: authenticate :: String -> String -> IO (Either String Identifier)
- Network.Gitit.Server: compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m) => m String
+ Network.Gitit.Server: compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) => m String
Files
- CHANGES +41/−0
- gitit.cabal +38/−42
- gitit.hs +5/−2
- src/Network/Gitit/Authentication/Github.hs +13/−1
- src/Network/Gitit/Config.hs +9/−6
- src/Network/Gitit/ContentTransformer.hs +34/−25
- src/Network/Gitit/Export.hs +26/−16
- src/Network/Gitit/Feed.hs +56/−2
- src/Network/Gitit/Rpxnow.hs +15/−21
- src/Network/Gitit/Util.hs +3/−3
CHANGES view
@@ -1,3 +1,44 @@+Version 0.13.0.0 released 03 June 2020++ * Allow building with GHC 8.8++ + Network.Gitit.Rpxnow: change return type of `authenticate` to+ avoid using removed instances of `Monad.fail`++ * Upgrade dependencies and add nix section to stack.yaml+ (Fabián Heredia Montiel).++ * Fixes to compile with feed-1.3.x (octalsrc).+ The changes to EntryContent in feed-1.2.0.0 were reverted+ in 1.3.0.0++ * Fixes to compile with network-3.x (octalsrc).+ network-3.0.0.0 moves the Network.BSD module into its own+ "network-bsd" package and removes deprecated API elements. This+ requires a new dependency on "network-bsd" and a code change to stop+ using the removed inet_addr function.+ This change also adds < 3.2 as an upper bound for network (there was+ previously no upper bound).++ * Fixes to compile with hoauth2-1.11.x (octalsrc).+ This also fixes type mismatches that prevent compiling with+ hoauth-1.9.x++ * Fixes to compile with GHC 8.8.x, API change in Network.Gitit.Rpxnow+ (octalsrc). GHC 8.8's base-4.13.0.0 removes `fail` from Monad,+ requiring a few uses of `fail` to be removed and the json dependency+ to be updated. Because arbitrary `Monad` instances no longer+ support failure, the `Monad m` used in the return type of+ Network.Gitit.Rpxnow.authenticate has been fixed as `Either String`.++ * Allow pandoc 2.9.x.++ * Diff fixes in Feed.++ * Modernize cabal file (require cabal 2.0).++ * Changes to use filestore 0.6.4.+ Version 0.12.3.2 released 31 Dec 2018 * Remove references to gitit.net in cabal file.
gitit.cabal view
@@ -1,6 +1,6 @@+cabal-version: 2.0 name: gitit-version: 0.12.3.2-Cabal-version: >= 1.8+version: 0.13.0.0 build-type: Simple synopsis: Wiki using happstack, git or darcs, and pandoc. description: Gitit is a wiki backed by a git, darcs, or mercurial@@ -100,10 +100,6 @@ type: git location: git://github.com/jgm/gitit.git -Flag network-uri- Description: Get Network.URI from the network-uri package- Default: True- Flag plugins description: Compile in support for plugins. This will increase the size of the executable and the memory it uses, so those who will not need@@ -125,6 +121,7 @@ Network.Gitit.Page, Network.Gitit.Feed, Network.Gitit.Compat.Except, Paths_gitit+ autogen-modules: Paths_gitit build-depends: base >= 4.9 && < 5, syb, filepath,@@ -138,49 +135,51 @@ directory, mtl, old-time,- pandoc >= 2.2,- pandoc-types >= 1.17.4.2 && < 1.18,- skylighting >= 0.7.4 && < 0.8,+ pandoc >= 2.9 && < 2.10,+ pandoc-types >= 1.20 && < 1.21,+ skylighting >= 0.8.2.3 && < 0.9, bytestring, text, random, utf8-string >= 0.3 && < 1.1,- SHA > 1 && < 1.7,- HTTP >= 4000.0 && < 4000.4,+ SHA > 1,+ HTTP >= 4000.0, HStringTemplate >= 0.6 && < 0.9,- old-locale >= 1,- time >= 1.1 && < 1.10,+ old-locale,+ time, recaptcha >= 0.1,- filestore >= 0.6 && < 0.7,+ filestore >= 0.6.4 && < 0.7, zlib >= 0.5 && < 0.7,- url >= 2.1 && < 2.2,- happstack-server >= 7.0 && < 7.6,- base64-bytestring >= 0.1 && < 1.1,+ url >= 2.1,+ happstack-server >= 7.5 && < 7.7,+ base64-bytestring >= 0.1, xml >= 1.3.5,- hslogger >= 1 && < 1.3,- ConfigFile >= 1 && < 1.2,- feed >= 1.0 && < 1.1,+ hslogger >= 1,+ ConfigFile >= 1,+ feed >= 1.0 && < 1.4,+ xml-types >= 0.3, xss-sanitize >= 0.3 && < 0.4, tagsoup >= 0.13 && < 0.15, blaze-html >= 0.4 && < 0.10,- json >= 0.4 && < 0.10,- uri-bytestring >= 0.2.3.3 && <= 0.4,+ json >= 0.4 && < 0.11,+ uri-bytestring >= 0.2.3.3, split,- hoauth2 >= 1.3.0 && < 1.9,- xml-conduit >= 1.5 && < 1.9,+ hoauth2 >= 1.3.0 && < 1.12,+ xml-conduit >= 1.5 && < 1.10, http-conduit >= 2.1.6 && < 2.4, http-client-tls >= 0.2.2 && < 0.4, aeson >= 0.7 && < 1.5,- uuid >= 1.3 && < 1.4- if flag(network-uri)- build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6- else- build-depends: network >= 2 && < 2.6+ uuid >= 1.3 && < 1.4,+ network-uri >= 2.6,+ network >= 2.6 && < 3.2,+ network-bsd >= 2.8.1 && < 2.9,+ doctemplates >= 0.7.1 if flag(plugins) exposed-modules: Network.Gitit.Interface build-depends: ghc, ghc-paths cpp-options: -D_PLUGINS- extensions: CPP+ default-extensions: CPP+ default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind ghc-prof-options: -fprof-auto-exported @@ -194,23 +193,20 @@ bytestring, text, utf8-string,- directory+ directory,+ network-uri >= 2.6,+ network >= 2.6 other-modules: Paths_gitit- if flag(network-uri)- build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6- else- build-depends: network >= 2 && < 2.6- extensions: CPP+ default-extensions: CPP+ default-language: Haskell2010 ghc-options: -Wall -threaded -fno-warn-unused-do-bind ghc-prof-options: -fprof-auto-exported -rtsopts Executable expireGititCache hs-source-dirs: . main-is: expireGititCache.hs- build-depends: base >= 4.9 && < 5, HTTP, url, filepath, syb- if flag(network-uri)- build-depends: network-uri >= 2.6 && < 2.7, network >= 2.6- else- build-depends: network >= 2 && < 2.6+ build-depends: base >= 4.9 && < 5, HTTP, url, filepath, syb,+ network-uri >= 2.6,+ network >= 2.6 ghc-options: -Wall-+ default-language: Haskell2010
gitit.hs view
@@ -96,8 +96,11 @@ -- open the requested interface sock <- socket AF_INET Stream defaultProtocol setSocketOption sock ReuseAddr 1- device <- inet_addr (address conf)- bind sock (SockAddrInet (toEnum (portNumber conf)) device)+ let portNum = show (portNumber conf)+ addrs <- getAddrInfo Nothing (Just $ address conf) (Just portNum)+ case addrs of+ addr:_ -> bind sock $ addrAddress addr+ [] -> error $ "Could not resolve " ++ address conf ++ ":" ++ portNum listen sock 10 -- start the server
src/Network/Gitit/Authentication/Github.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-} module Network.Gitit.Authentication.Github ( loginGithubUser , getGithubUser@@ -102,13 +102,25 @@ vState <- liftM Just (look "state") `mplus` return Nothing return GithubCallbackPars {rCode = vCode, rState = vState} +#if MIN_VERSION_hoauth2(1, 9, 0)+userInfo :: Manager -> AccessToken -> IO (Either BSL.ByteString GithubUser)+#else userInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors GithubUser)+#endif userInfo mgr token = authGetJSON mgr token $ githubUri "/user" +#if MIN_VERSION_hoauth2(1, 9, 0)+mailInfo :: Manager -> AccessToken -> IO (Either BSL.ByteString [GithubUserMail])+#else mailInfo :: Manager -> AccessToken -> IO (OAuth2Result OA.Errors [GithubUserMail])+#endif mailInfo mgr token = authGetJSON mgr token $ githubUri "/user/emails" +#if MIN_VERSION_hoauth2(1, 9, 0)+orgInfo :: Text -> Text -> Manager -> AccessToken -> IO (Either BSL.ByteString BSL.ByteString)+#else orgInfo :: Text -> Text -> Manager -> AccessToken -> IO (OAuth2Result OA.Errors BSL.ByteString)+#endif orgInfo gitLogin githubOrg mgr token = do let url = githubUri $ "/orgs/" `BS.append` encodeUtf8 githubOrg `BS.append` "/members/" `BS.append` encodeUtf8 gitLogin authGetBS mgr token url
src/Network/Gitit/Config.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu> @@ -46,7 +46,6 @@ import Network.Gitit.Compat.Except import Control.Monad import Control.Monad.Trans-import Text.Pandoc.Error (handleError) forceEither :: Show e => Either e a -> a@@ -138,7 +137,7 @@ let markupHelpFile = show pt ++ if lhs then "+LHS" else "" markupHelpPath <- liftIO $ getDataFileName $ "data" </> "markupHelp" </> markupHelpFile markupHelp' <- liftIO $ readFileUTF8 markupHelpPath- markupHelpText <- liftIO $ handleError $ runPure $ do + markupHelpText <- liftIO $ handleError $ runPure $ do helpDoc <- readMarkdown def{ readerExtensions = getDefaultExtensions "markdown" } markupHelp' writeHtml5String def helpDoc @@ -256,7 +255,11 @@ then fmap Just (getGithubProp "github-org") else return Nothing let cfgOAuth2 = OAuth2 { oauthClientId = T.pack cfOauthClientId+#if MIN_VERSION_hoauth2(1, 11, 0)+ , oauthClientSecret = Just $ T.pack cfOauthClientSecret+#else , oauthClientSecret = T.pack cfOauthClientSecret+#endif , oauthCallback = Just cfOauthCallback , oauthOAuthorizeEndpoint = cfOauthOAuthorizeEndpoint , oauthAccessTokenEndpoint = cfOauthAccessTokenEndpoint@@ -273,8 +276,8 @@ Right uri -> return uri fromQuotedMultiline :: String -> String-fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` " \t\n")- where doline = dropWhile (`elem` " \t") . dropGt+fromQuotedMultiline = unlines . map doline . lines . dropWhile (`elem` [' ','\t','\n'])+ where doline = dropWhile (`elem` [' ','\t']) . dropGt dropGt ('>':' ':xs) = xs dropGt ('>':xs) = xs dropGt x = x@@ -301,7 +304,7 @@ lrStrip :: String -> String lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace- where isWhitespace = (`elem` " \t\n")+ where isWhitespace = (`elem` [' ','\t','\n']) getDefaultConfigParser :: IO ConfigParser getDefaultConfigParser = do
src/Network/Gitit/ContentTransformer.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>, Anton van Straaten <anton@appsolutions.com>@@ -72,8 +73,8 @@ import qualified Control.Exception as E import Control.Monad.State import Control.Monad.Reader (ask)+import Control.Monad.Except (throwError) import Data.Foldable (traverse_)-import Data.Char (toLower) import Data.List (stripPrefix) import Data.Maybe (isNothing, mapMaybe) import Data.Semigroup ((<>))@@ -91,7 +92,6 @@ import Network.URL (encString) import System.FilePath import qualified Text.Pandoc.Builder as B-import Text.Pandoc.Extensions (getDefaultExtensions) import Text.HTML.SanitizeXSS (sanitizeBalance) import Skylighting hiding (Context) import Text.Pandoc hiding (MathML, WebTeX, MathJax)@@ -530,15 +530,20 @@ bird <- liftM ctxBirdTracks get cfg <- lift getConfig let tpl = "$if(toc)$<div id=\"TOC\">\n$toc$\n</div>\n$endif$\n$body$"+ compiledTemplate <- liftIO $ runIOorExplode $ do+ res <- runWithDefaultPartials $ compileTemplate "toc" tpl+ case res of+ Right t -> return t+ Left e -> throwError $ PandocTemplateError $ T.pack e return $ primHtml $ T.unpack . (if xssSanitize cfg then sanitizeBalance else id) $ either E.throw id . runPure $ writeHtml5String def{- writerTemplate = Just tpl+ writerTemplate = Just compiledTemplate , writerHTMLMathMethod = case mathMethod cfg of MathML -> Pandoc.MathML- WebTeX u -> Pandoc.WebTeX u- MathJax u -> Pandoc.MathJax u+ WebTeX u -> Pandoc.WebTeX $ T.pack u+ MathJax u -> Pandoc.MathJax $ T.pack u RawTeX -> Pandoc.PlainMath , writerTableOfContents = toc , writerHighlightStyle = Just pygments@@ -640,7 +645,9 @@ updateLayout $ \layout -> layout{ pgTitle = title' } return $ if null title' then Pandoc nullMeta blocks- else Pandoc (B.setMeta "title" (B.str title') nullMeta) blocks+ else Pandoc+ (B.setMeta "title" (B.str (T.pack title')) nullMeta)+ blocks -- | Adds javascript links for math support. addMathSupport :: a -> ContentTransformer a@@ -691,7 +698,7 @@ readerFor :: PageType -> Bool -> String -> Either PandocError Pandoc readerFor pt lhs =- let defExts = getDefaultExtensions $ map toLower $ show pt+ let defExts = getDefaultExtensions $ T.toLower $ T.pack $ show pt defPS = def{ readerExtensions = defExts <> extensionsFromList [Ext_emoji] <> getPageTypeDefaultExtensions pt lhs@@ -715,9 +722,10 @@ -- | Convert links with no URL to wikilinks. convertWikiLinks :: Config -> Inline -> Inline convertWikiLinks cfg (Link attr ref ("", "")) | useAbsoluteUrls cfg =- Link attr ref ("/" </> baseUrl cfg </> inlinesToURL ref, "Go to wiki page")+ Link attr ref (T.pack ("/" </> baseUrl cfg </> inlinesToURL ref),+ "Go to wiki page") convertWikiLinks _cfg (Link attr ref ("", "")) =- Link attr ref (inlinesToURL ref, "Go to wiki page")+ Link attr ref (T.pack (inlinesToURL ref), "Go to wiki page") convertWikiLinks _cfg x = x -- | Derives a URL from a list of Pandoc Inline elements.@@ -726,28 +734,29 @@ -- | Convert a list of inlines into a string. inlinesToString :: [Inline] -> String-inlinesToString = concatMap go- where go x = case x of+inlinesToString = T.unpack . mconcat . map go+ where go :: Inline -> T.Text+ go x = case x of Str s -> s- Emph xs -> concatMap go xs- Strong xs -> concatMap go xs- Strikeout xs -> concatMap go xs- Superscript xs -> concatMap go xs- Subscript xs -> concatMap go xs- SmallCaps xs -> concatMap go xs- Quoted DoubleQuote xs -> '"' : (concatMap go xs ++ "\"")- Quoted SingleQuote xs -> '\'' : (concatMap go xs ++ "'")- Cite _ xs -> concatMap go xs+ Emph xs -> mconcat $ map go xs+ Strong xs -> mconcat $ map go xs+ Strikeout xs -> mconcat $ map go xs+ Superscript xs -> mconcat $ map go xs+ Subscript xs -> mconcat $ map go xs+ SmallCaps xs -> mconcat $ map go xs+ Quoted DoubleQuote xs -> "\"" <> mconcat (map go xs) <> "\""+ Quoted SingleQuote xs -> "'" <> mconcat (map go xs) <> "'"+ Cite _ xs -> mconcat $ map go xs Code _ s -> s Space -> " " SoftBreak -> " " LineBreak -> " "- Math DisplayMath s -> "$$" ++ s ++ "$$"- Math InlineMath s -> "$" ++ s ++ "$"+ Math DisplayMath s -> "$$" <> s <> "$$"+ Math InlineMath s -> "$" <> s <> "$" RawInline (Format "tex") s -> s RawInline _ _ -> ""- Link _ xs _ -> concatMap go xs- Image _ xs _ -> concatMap go xs+ Link _ xs _ -> mconcat $ map go xs+ Image _ xs _ -> mconcat $ map go xs Note _ -> ""- Span _ xs -> concatMap go xs+ Span _ xs -> mconcat $ map go xs
src/Network/Gitit/Export.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu> @@ -26,11 +28,13 @@ import Text.Pandoc.PDF (makePDF) import Text.Pandoc.SelfContained as SelfContained import qualified Text.Pandoc.UTF8 as UTF8+import qualified Data.Map as M import Network.Gitit.Server import Network.Gitit.Framework (pathForPage) import Network.Gitit.State (getConfig) import Network.Gitit.Types import Network.Gitit.Cache (cacheContents, lookupCache)+import Text.DocTemplates as DT import Control.Monad.Trans (liftIO) import Control.Monad (unless) import Text.XHtml (noHtml)@@ -39,7 +43,6 @@ import System.FilePath ((</>), takeDirectory) import System.Directory (doesFileExist) import Text.HTML.SanitizeXSS-import Text.Pandoc.Writers.RTF (writeRTF) import Data.ByteString.Lazy (fromStrict) import Data.Text (Text) import qualified Data.Text as T@@ -61,8 +64,8 @@ else return doc doc'' <- liftIO $ runIO $ do setUserDataDir $ pandocUserData cfg- template <- getDefaultTemplate templ- fn opts{ writerTemplate = Just template } doc'+ compiledTemplate <- compileDefaultTemplate (T.pack templ)+ fn opts{ writerTemplate = Just compiledTemplate } doc' either (liftIO . throwIO) (ok . setContentType mimetype . (if null ext then id else setFilename (page ++ "." ++ ext)) .@@ -79,7 +82,7 @@ cfg <- getConfig let math = case mathMethod cfg of MathML -> Pandoc.MathML- WebTeX u -> Pandoc.WebTeX u+ WebTeX u -> Pandoc.WebTeX $ T.pack u _ -> Pandoc.PlainMath let opts' = defaultRespOptions { writerIncremental = True , writerHTMLMathMethod = math}@@ -88,18 +91,21 @@ -- needed for the slides.) We then pass the body into the -- slide template using the 'body' variable. Pandoc meta blocks <- fixURLs page doc- docOrError <- liftIO $ runIO $ do + docOrError <- liftIO $ runIO $ do setUserDataDir $ pandocUserData cfg body' <- writeHtml5String opts' (Pandoc meta blocks) -- just body let body'' = T.unpack $ (if xssSanitize cfg then sanitizeBalance else id) $ body'+ let setVariable key val (DT.Context ctx) =+ DT.Context $ M.insert (T.pack key) (toVal (T.pack val)) ctx variables' <- if mathMethod cfg == MathML then do s <- readDataFile "MathMLinHTML.js"- return [("mathml-script", UTF8.toString s)]- else return []- template <- getDefaultTemplate templ+ return $ setVariable "mathml-script"+ (UTF8.toString s) mempty+ else return mempty+ compiledTemplate <- compileDefaultTemplate (T.pack templ) dzcore <- if templ == "dzslides" then do dztempl <- readDataFile $ "dzslides" </> "template.html"@@ -109,14 +115,17 @@ else return "" let opts'' = opts'{ writerVariables =- ("body",body''):("dzslides-core",dzcore):("highlighting-css",pygmentsCss):variables'- ,writerTemplate = Just template }+ setVariable "body" body'' $+ setVariable "dzslides-core" dzcore $+ setVariable "highlighting-css" pygmentsCss+ $ variables'+ ,writerTemplate = Just compiledTemplate } h <- fn opts'' (Pandoc meta [])- makeSelfContained (T.unpack h)+ makeSelfContained h either (liftIO . throwIO) (ok . setContentType "text/html;charset=UTF-8" . (setFilename (page ++ ".html")) .- toResponseBS B.empty . UTF8.fromStringLazy)+ toResponseBS B.empty . L.fromStrict . UTF8.fromText) docOrError respondLaTeX :: String -> Pandoc -> Handler@@ -209,9 +218,10 @@ res <- liftIO $ runIO $ do setUserDataDir $ pandocUserData cfg setInputFiles [baseUrl cfg]- template <- getDefaultTemplate $ if useBeamer then "beamer" else "latex"+ let templ = if useBeamer then "beamer" else "latex"+ compiledTemplate <- compileDefaultTemplate templ makePDF "pdflatex" [] (if useBeamer then writeBeamer else writeLaTeX)- defaultRespOptions{ writerTemplate = Just template+ defaultRespOptions{ writerTemplate = Just compiledTemplate , writerTableOfContents = toc } pndc either (liftIO . throwIO) return res @@ -242,8 +252,8 @@ let repoPath = repositoryPath cfg let go (Image attr ils (url, title)) = do- fixedURL <- fixURL url- return $ Image attr ils (fixedURL, title)+ fixedURL <- fixURL $ T.unpack url+ return $ Image attr ils (T.pack fixedURL, title) go x = return x fixURL ('/':url) = resolve url
src/Network/Gitit/Feed.hs view
@@ -36,7 +36,7 @@ import Data.Ord (comparing) import Network.URI (isUnescapedInURI, escapeURIString) import System.FilePath (dropExtension, takeExtension, (<.>))-import Data.FileStore.Generic (Diff(..), diff)+import Data.FileStore.Generic (Diff, PolyDiff(..), diff) import Data.FileStore.Types (history, retrieve, Author(authorName), Change(..), FileStore, Revision(..), TimeRange(..), RevisionId) import Text.Atom.Feed (nullEntry, nullFeed, nullLink, nullPerson,@@ -46,6 +46,7 @@ import Text.XML.Light as XML (showContent, Content(..), Element(..), blank_element, QName(..), blank_name, CData(..), blank_cdata) import Text.XML as Text.XML (renderText, Document(..), Element(..), Prologue(..), def, fromXMLElement)+import qualified Data.XML.Types as XMLTypes import Data.Version (showVersion) import Paths_gitit (version) @@ -127,38 +128,91 @@ } where baseNull = nullFeed (T.pack home) (TextString (T.pack title)) now +-- Several of the following functions have been given an alternate+-- version patched in using CPP specifically when the `feed` library+-- used is version 1.2.x+--+-- The 1.2.0.0 release of `feed` introduced an API change that was+-- reverted in 1.3.0.0. When feed-1.2.x is sufficiently out of use,+-- the dependency lower-bound for feed should be updated to >= 1.3 and+-- the second alternative (#else condition) in each of the CPP+-- invocations below can be removed.+--+-- https://github.com/bergmark/feed/issues/35+ revisionToEntry :: String -> (Revision, [(FilePath, [Diff [String]])]) -> Entry revisionToEntry home (Revision{ revId = rid, revDateTime = rdt, revAuthor = ra, revDescription = rd, revChanges = rv}, diffs) =- baseEntry{ entryContent = Just $ HTMLContent $ T.pack $ concat $ map showContent $ map diffFile diffs+ baseEntry{ entryContent = Just $ HTMLContent content , entryAuthors = [authorToPerson ra], entryLinks = [ln] } where baseEntry = nullEntry (T.pack url) title (T.pack $ formatFeedTime rdt) url = home ++ escape (extract $ head rv) ++ "?revision=" ++ rid ln = (nullLink (T.pack url)) {linkRel = Just (Left "alternate")} title = TextString $ T.pack $ (takeWhile ('\n' /=) rd) ++ " - " ++ (intercalate ", " $ map show rv)+ df = map diffFile diffs+#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0))+ content = T.pack $ concat $ map showContent df+#else+ content = XMLTypes.Element (XMLTypes.Name "div" Nothing Nothing) [] df+#endif +#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0)) diffFile :: (FilePath, [Diff [String]]) -> Content diffFile (fp, d) = enTag "div" $ header : text where header = enTag1 "h1" $ enText fp text = map (enTag1 "p") $ concat $ map diffLines d+#else+diffFile :: (FilePath, [Diff [String]]) -> XMLTypes.Node+diffFile (fp, d) =+ enTag "div" $ header : text+ where+ header = enTag1 "h1" $ enText $ T.pack fp+ text = map (enTag1 "p") $ concat $ map diffLines d+#endif +#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0)) diffLines :: Diff [String] -> [Content] diffLines (First x) = map (enTag1 "s" . enText) x diffLines (Second x) = map (enTag1 "b" . enText) x diffLines (Both x _) = map enText x+#else+diffLines :: Diff [String] -> [XMLTypes.Node]+diffLines (First x) = map (enTag1 "s" . enText . T.pack) x+diffLines (Second x) = map (enTag1 "b" . enText . T.pack) x+diffLines (Both x _) = map (enText . T.pack) x+#endif +#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0)) enTag :: String -> [Content] -> Content enTag tag content = Elem blank_element{ elName=blank_name{qName=tag} , elContent=content }+#else+enTag :: T.Text -> [XMLTypes.Node] -> XMLTypes.Node+enTag tag content = XMLTypes.NodeElement $+ XMLTypes.Element+ (XMLTypes.Name tag Nothing Nothing)+ [] content+#endif++#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0)) enTag1 :: String -> Content -> Content+#else+enTag1 :: T.Text -> XMLTypes.Node -> XMLTypes.Node+#endif enTag1 tag content = enTag tag [content]++#if MIN_VERSION_feed(1, 3, 0) || (! MIN_VERSION_feed(1, 2, 0)) enText :: String -> Content enText content = Text blank_cdata{cdData=content}+#else+enText :: T.Text -> XMLTypes.Node+enText content = XMLTypes.NodeContent (XMLTypes.ContentText content)+#endif -- gitit is set up not to reveal registration emails authorToPerson :: Author -> Person
src/Network/Gitit/Rpxnow.hs view
@@ -15,18 +15,17 @@ import Network.HTTP (urlEncodeVars) -- | Make a post request with parameters to the URL and return a response.-curl :: Monad m- => String -- ^ URL+curl :: String -- ^ URL -> [(String, String)] -- ^ Post parameters- -> IO (m String) -- ^ Response body+ -> IO (Either String String) -- ^ Response body curl url params = do (Nothing, Just hout, Just herr, phandle) <- createProcess $ (proc "curl" [url, "-d", urlEncodeVars params] ) { std_out = CreatePipe, std_err = CreatePipe } exitCode <- waitForProcess phandle case exitCode of- ExitSuccess -> hGetContents hout >>= return . return- _ -> hGetContents herr >>= return . fail+ ExitSuccess -> hGetContents hout >>= return . Right+ _ -> hGetContents herr >>= return . Left @@ -38,10 +37,9 @@ deriving Show -- | Attempt to log a user in.-authenticate :: Monad m- => String -- ^ API key given by RPXNOW.+authenticate :: String -- ^ API key given by RPXNOW. -> String -- ^ Token passed by client.- -> IO (m Identifier)+ -> IO (Either String Identifier) authenticate apiKey token = do body <- curl "https://rpxnow.com/api/v2/auth_info"@@ -49,20 +47,20 @@ , ("token", token) ] case body of- Left s -> return $ fail $ "Unable to connect to rpxnow: " ++ s+ Left s -> return $ Left $ "Unable to connect to rpxnow: " ++ s Right b -> case decode b >>= getObject of- Error s -> return $ fail $ "Not a valid JSON response: " ++ s+ Error s -> return $ Left $ "Not a valid JSON response: " ++ s Ok o -> case valFromObj "stat" o of- Error _ -> return $ fail "Missing 'stat' field"- Ok "ok" -> return $ parseProfile o- Ok stat -> return $ fail $ "Login not accepted: " ++ stat+ Error _ -> return $ Left "Missing 'stat' field"+ Ok "ok" -> return $ resultToEither $ parseProfile o+ Ok stat -> return $ Left $ "Login not accepted: " ++ stat -parseProfile :: Monad m => JSObject JSValue -> m Identifier+parseProfile :: JSObject JSValue -> Result Identifier parseProfile v = do- profile <- resultToMonad $ valFromObj "profile" v >>= getObject- ident <- resultToMonad $ valFromObj "identifier" profile+ profile <- valFromObj "profile" v >>= getObject+ ident <- valFromObj "identifier" profile let pairs = fromJSObject profile pairs' = filter (\(k, _) -> k /= "identifier") pairs pairs'' = map fromJust . filter isJust . map takeString $ pairs'@@ -72,10 +70,6 @@ takeString (k, JSString v) = Just (k, fromJSString v) takeString _ = Nothing -getObject :: Monad m => JSValue -> m (JSObject JSValue)+getObject :: JSValue -> Result (JSObject JSValue) getObject (JSObject o) = return o getObject _ = fail "Not an object"--resultToMonad :: Monad m => Result a -> m a-resultToMonad (Ok x) = return x-resultToMonad (Error s) = fail s
src/Network/Gitit/Util.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify@@ -81,13 +81,13 @@ -- | Split a string containing a list of categories. splitCategories :: String -> [String] splitCategories = words . map puncToSpace . trim- where puncToSpace x | x `elem` ".,;:" = ' '+ where puncToSpace x | x `elem` ['.',',',';',':'] = ' ' puncToSpace x = x -- | Trim leading and trailing spaces. trim :: String -> String trim = reverse . trimLeft . reverse . trimLeft- where trimLeft = dropWhile (`elem` " \t")+ where trimLeft = dropWhile (`elem` [' ','\t']) -- | Show Bool as "yes" or "no". yesOrNo :: Bool -> String