diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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. diff --git a/gitit.cabal b/gitit.cabal --- a/gitit.cabal +++ b/gitit.cabal @@ -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 diff --git a/gitit.hs b/gitit.hs --- a/gitit.hs +++ b/gitit.hs @@ -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 diff --git a/src/Network/Gitit/Authentication/Github.hs b/src/Network/Gitit/Authentication/Github.hs --- a/src/Network/Gitit/Authentication/Github.hs +++ b/src/Network/Gitit/Authentication/Github.hs @@ -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 diff --git a/src/Network/Gitit/Config.hs b/src/Network/Gitit/Config.hs --- a/src/Network/Gitit/Config.hs +++ b/src/Network/Gitit/Config.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables, OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane @@ -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 diff --git a/src/Network/Gitit/ContentTransformer.hs b/src/Network/Gitit/ContentTransformer.hs --- a/src/Network/Gitit/ContentTransformer.hs +++ b/src/Network/Gitit/ContentTransformer.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane , Anton van Straaten @@ -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)$
\n$toc$\n
\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 diff --git a/src/Network/Gitit/Export.hs b/src/Network/Gitit/Export.hs --- a/src/Network/Gitit/Export.hs +++ b/src/Network/Gitit/Export.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {- Copyright (C) 2009 John MacFarlane @@ -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 diff --git a/src/Network/Gitit/Feed.hs b/src/Network/Gitit/Feed.hs --- a/src/Network/Gitit/Feed.hs +++ b/src/Network/Gitit/Feed.hs @@ -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 diff --git a/src/Network/Gitit/Rpxnow.hs b/src/Network/Gitit/Rpxnow.hs --- a/src/Network/Gitit/Rpxnow.hs +++ b/src/Network/Gitit/Rpxnow.hs @@ -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 diff --git a/src/Network/Gitit/Util.hs b/src/Network/Gitit/Util.hs --- a/src/Network/Gitit/Util.hs +++ b/src/Network/Gitit/Util.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} {- Copyright (C) 2009 John MacFarlane 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