diff --git a/.gitignore b/.gitignore index ef9c384..0c8a953 100644 --- a/.gitignore +++ b/.gitignore @@ -20,6 +20,8 @@ cabal.config TAGS .DS_Store *~ +*.swp +*.swo *# state/ config.json diff --git a/guide.cabal b/guide.cabal index 0ee176a..704837e 100644 --- a/guide.cabal +++ b/guide.cabal @@ -63,6 +63,7 @@ library Guide.Diff.Tokenize Guide.Diff.Merge Guide.Markdown + Guide.Archival Guide.Search Guide.JS Guide.Views diff --git a/src/Guide/Archival.hs b/src/Guide/Archival.hs new file mode 100644 index 0000000..ba97c17 --- /dev/null +++ b/src/Guide/Archival.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE OverloadedStrings #-} + + +-- | Methods for working with archive.org. Right now the admin interface +-- provides a list of broken links together with links to their archived +-- copies; in the future we might add automatic archival and automatic link +-- replacement. +module Guide.Archival +( + ArchivalStatus(..), + getArchivalStatus, +) +where + + +import Imports + +-- text +import qualified Data.Text.All as T +-- JSON +import qualified Data.Aeson as A +-- network +import Network.HTTP.Client + +import Guide.Utils + + +-- | Get status of a link on archive.org. +-- +-- 'Left' means that an error happened when connecting to archive.org, or +-- that its response couldn't be parsed. +getArchivalStatus :: Manager -> Url -> IO (Either String ArchivalStatus) +getArchivalStatus manager lnk = + handle (pure . Left . show @HttpException) $ do + req <- setQueryString [("url", Just (T.toByteString lnk))] <$> + parseRequest waybackUrl + fromJsonWith responseParser . responseBody <$!> httpLbs req manager + where + waybackUrl = "http://archive.org/wayback/available" + responseParser = A.withObject "archive.org response" $ + (A..: "archived_snapshots") >=> (A..: "closest") + +data ArchivalStatus = ArchivalStatus { + asAvailable :: Bool, -- ^ Whether the link is available + asUrl :: Url, -- ^ Link to archived page + asTimestamp :: UTCTime, -- ^ When the page was archived + asStatus :: Text } -- ^ HTTP status ("200", "404", etc) + deriving (Eq, Show) + +-- For an example, look at archived_snapshots.closest in +-- : +-- +-- { "status": "200" +-- , "available": true +-- , "url": "http://web.archive.org/web/20170819042701/http://example.com" +-- , "timestamp": "20170819042701" } +instance A.FromJSON ArchivalStatus where + parseJSON = A.withObject "ArchivalStatus" $ \o -> do + asAvailable <- o A..: "available" + asUrl <- o A..: "url" + asStatus <- o A..: "status" + asTimestamp <- o A..: "timestamp" >>= + parseTimeM True defaultTimeLocale "%Y%m%d%H%M%S" + pure ArchivalStatus{..} diff --git a/src/Guide/Handlers.hs b/src/Guide/Handlers.hs index 06e7774..d04fc0a 100644 --- a/src/Guide/Handlers.hs +++ b/src/Guide/Handlers.hs @@ -318,7 +318,7 @@ addMethods = do otherMethods :: GuideM ctx () otherMethods = do - -- Moving things + -- # Moving things -- Move item Spock.post (moveRoute itemVar) $ \itemId -> do direction :: Text <- param' "direction" @@ -332,7 +332,7 @@ otherMethods = do edit <- dbUpdate (MoveTrait itemId traitId (direction == "up")) addEdit edit --- Deleting things + -- # Deleting things -- Delete category Spock.post (deleteRoute categoryVar) $ \catId -> uncache (CacheCategory catId) $ do @@ -349,7 +349,7 @@ otherMethods = do mbEdit <- dbUpdate (DeleteTrait itemId traitId) mapM_ addEdit mbEdit - -- Feeds + -- # Feeds -- TODO: this link shouldn't be absolute [absolute-links] baseUrl <- (// "haskell") . _baseUrl <$> getConfig diff --git a/src/Guide/JS.hs b/src/Guide/JS.hs index 6873128..28a70a6 100644 --- a/src/Guide/JS.hs +++ b/src/Guide/JS.hs @@ -58,7 +58,8 @@ allJSFunctions = JS . T.unlines . map fromJS $ [ -- Admin things acceptEdit, undoEdit, acceptBlock, undoBlock, - createCheckpoint ] + createCheckpoint, + saveToArchiveOrg] -- | A class for things that can be converted to Javascript syntax. class ToJS a where toJS :: a -> JS @@ -677,6 +678,15 @@ createCheckpoint = }); |] +saveToArchiveOrg :: JSFunction a => a +saveToArchiveOrg = + makeJSFunction "saveToArchiveOrg" ["link"] + [text| + $.post('http://web.archive.org/save/' + link) + .done(function () { + console.log(link + " saved to archive.org") + }); + |] -- When adding a function, don't forget to add it to 'allJSFunctions'! escapeJSString :: Text -> Text @@ -726,4 +736,3 @@ selectChildren a b = JQuerySelector $ format "{} > {}" a b selectSection :: JQuerySelector -> Text -> JQuerySelector selectSection a b = JQuerySelector $ format "{} > .section.{}" a b - diff --git a/src/Guide/Main.hs b/src/Guide/Main.hs index afd16b9..0f813d4 100644 --- a/src/Guide/Main.hs +++ b/src/Guide/Main.hs @@ -336,13 +336,15 @@ loginAction = do loginAttempt <- dbQuery $ LoginUser loginEmail (T.toByteString loginUserPassword) case loginAttempt of - Just user -> do + Right user -> do modifySession (sessionUserID .~ Just (user ^. userID)) Spock.redirect "/" - -- TODO: show error message/validation of input - Nothing -> do + -- TODO: *properly* show error message/validation of input + Left err -> do formHtml <- protectForm loginFormView v - lucidWithConfig $ renderRegister formHtml + lucidWithConfig $ renderRegister $ do + div_ $ toHtml ("Error: " <> err) + formHtml logoutAction :: GuideAction ctx () logoutAction = do @@ -446,6 +448,7 @@ installTerminationCatcher thread = void $ do -- The user won't be added if it exists already. createAdminUser :: GuideApp () createAdminUser = do + dbUpdate DeleteAllUsers pass <- T.toByteString . _adminPassword <$> getConfig user <- makeUser "admin" "admin@guide.aelve.com" pass void $ dbUpdate $ CreateUser (user & userIsAdmin .~ True) diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 34b771d..99d10d4 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -79,7 +79,7 @@ module Guide.State LoadSession(..), StoreSession(..), DeleteSession(..), GetSessions(..), - GetUser(..), CreateUser(..), DeleteUser(..), + GetUser(..), CreateUser(..), DeleteUser(..), DeleteAllUsers(..), LoginUser(..), GetAdminUsers(..) @@ -750,17 +750,24 @@ deleteUser key = do logoutUserGlobally key setDirty +deleteAllUsers :: Acid.Update GlobalState () +deleteAllUsers = do + mapM_ logoutUserGlobally . M.keys =<< use users + users .= mempty + setDirty + -- | Given an email address and a password, return the user if it exists -- and the password is correct. -loginUser :: Text -> ByteString -> Acid.Query GlobalState (Maybe User) +loginUser :: Text -> ByteString -> Acid.Query GlobalState (Either String User) loginUser email password = do matches <- filter (\u -> u ^. userEmail == email) . toList <$> view users case matches of [user] -> if verifyUser user password - then return $ Just user - else return $ Nothing - _ -> return Nothing + then return $ Right user + else return $ Left "wrong password" + [] -> return $ Left "user not found" + _ -> return $ Left "more than one user found, please contact the admin" -- | Global logout of all of a user's active sessions logoutUserGlobally :: Uid User -> Acid.Update GlobalState () @@ -812,7 +819,7 @@ makeAcidic ''GlobalState [ 'loadSession, 'storeSession, 'deleteSession, 'getSessions, -- users - 'getUser, 'createUser, 'deleteUser, + 'getUser, 'createUser, 'deleteUser, 'deleteAllUsers, 'loginUser, 'getAdminUsers diff --git a/src/Guide/Utils.hs b/src/Guide/Utils.hs index df69be2..ef0afeb 100644 --- a/src/Guide/Utils.hs +++ b/src/Guide/Utils.hs @@ -46,6 +46,12 @@ module Guide.Utils randomLongUid, uid_, + -- * JSON + fromJson, + fromJsonWith, + toJson, + toJsonPretty, + -- * Lucid includeJS, includeCSS, @@ -76,8 +82,14 @@ import qualified Data.Set as S import System.Random -- Text import qualified Data.Text.All as T +-- Bytestring +import qualified Data.ByteString.Lazy as BSL -- JSON import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A +import qualified Data.Aeson.Types as A +import qualified Data.Aeson.Internal as A +import qualified Data.Aeson.Encode.Pretty as A -- Network import qualified Network.Socket as Network import Data.IP @@ -360,6 +372,56 @@ data Node uid_ :: Uid Node -> Attribute uid_ = id_ . uidToText +---------------------------------------------------------------------------- +-- JSON +---------------------------------------------------------------------------- + +class AsJson s where + -- | Parse JSON using the default JSON instance. + fromJson :: A.FromJSON a => s -> Either String a + fromJson = fromJsonWith A.parseJSON + + -- | Parse JSON using a custom parser. + fromJsonWith :: (A.Value -> A.Parser a) -> s -> Either String a + fromJsonWith p s = do + v <- fromJson s + case A.iparse p v of + A.IError path err -> Left (A.formatError path err) + A.ISuccess res -> Right res + + -- | Convert a value to JSON. + toJson :: A.ToJSON a => a -> s + + -- | Convert a value to pretty-printed JSON. + toJsonPretty :: A.ToJSON a => a -> s + +instance AsJson ByteString where + fromJson = A.eitherDecodeStrict + toJson = BSL.toStrict . A.encode + toJsonPretty = BSL.toStrict . A.encodePretty + +instance AsJson LByteString where + fromJson = A.eitherDecode + toJson = A.encode + toJsonPretty = A.encodePretty + +instance AsJson Text where + fromJson = A.eitherDecode . T.toLByteString + toJson = T.toStrict . A.encodeToLazyText + toJsonPretty = T.toStrict . A.encodePrettyToTextBuilder + +instance AsJson LText where + fromJson = A.eitherDecode . T.toLByteString + toJson = A.encodeToLazyText + toJsonPretty = T.toLazy . A.encodePrettyToTextBuilder + +instance AsJson A.Value where + fromJsonWith p v = case A.iparse p v of + A.IError path err -> Left (A.formatError path err) + A.ISuccess res -> Right res + toJson = A.toJSON + toJsonPretty = A.toJSON + ---------------------------------------------------------------------------- -- Lucid ---------------------------------------------------------------------------- diff --git a/src/Guide/Views.hs b/src/Guide/Views.hs index 71cf35e..afbacab 100644 --- a/src/Guide/Views.hs +++ b/src/Guide/Views.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE ScopedTypeVariables #-} {- | @@ -65,6 +67,7 @@ import Guide.Utils import Guide.JS (JS(..)) import qualified Guide.JS as JS import Guide.Markdown +import Guide.Archival import Guide.Diff hiding (DiffChunk) import qualified Guide.Diff as Diff import Guide.Cache @@ -808,8 +811,20 @@ on those
s. data LinkStatus = OK | Unparseable | Broken String deriving Show +data LinkInfo = LinkInfo { + -- | Link itself + linkUrl :: Url, + -- | A description of where the link is in Guide + linkLocation :: Text, + -- | Link status (ok, unparseable, etc) + linkStatus :: LinkStatus, + -- | Link status on archive.org (if archive.org is available) + linkArchivalStatus :: Either String ArchivalStatus + } + deriving (Show) + -- | Render links page with info about broken links -renderAdminLinks :: (MonadIO m) => GlobalState -> HtmlT m () +renderAdminLinks :: forall m . (MonadIO m) => GlobalState -> HtmlT m () renderAdminLinks globalState = do head_ $ do includeJS "/js.js" @@ -828,7 +843,7 @@ renderAdminLinks globalState = do div_ [id_ "stats"] $ do manager <- liftIO $ newManager tlsManagerSettings fullList <- liftIO $ forM allLinks $ \(lnk, location) -> do - resp <- if isURI (T.unpack lnk) then (do + lnkStatus <- if isURI (T.unpack lnk) then (do request <- parseRequest $ T.unpack lnk status' <- responseStatus <$> httpNoBody request manager print (lnk, status') @@ -838,56 +853,80 @@ renderAdminLinks globalState = do ) `catch` (return . handleHttpException) else pure Unparseable - pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp) - let (ok, unparseable, broken) = sortLinks fullList - - h2_ "Broken Links" - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - th_ "Status" - tbody_ $ do - for_ broken $ \(location, lnk, reason) -> do - tr_ $ do - td_ location - td_ lnk - td_ $ toHtml reason - h2_ "Unparseable Links" - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - tbody_ $ do - for_ unparseable $ \(cat, l) -> do - tr_ $ do - td_ cat - td_ l - h2_ "OK Links" - table_ [class_ "sortable"] $ do - thead_ $ tr_ $ do - th_ [class_ "sorttable_nosort"] "Category" - th_ [class_ "sorttable_nosort"] "Link" - tbody_ $ do - for_ ok $ \(cat, l) -> do - tr_ $ do - td_ cat - td_ l + archStatus <- liftIO (getArchivalStatus manager lnk) + pure $ LinkInfo { + linkUrl = lnk, + linkLocation = location, + linkStatus = lnkStatus, + linkArchivalStatus = archStatus } + renderUnparseableLinks fullList + renderBrokenLinks fullList + renderOKLinks fullList where handleHttpException :: HttpException -> LinkStatus handleHttpException (HttpExceptionRequest _ x) = Broken $ show x handleHttpException (InvalidUrlException _ x) = Broken x - sortLinks :: [(a, b, LinkStatus)] -> ([(a, b)], [(a, b)], [(a, b, String)]) - sortLinks = foldr sortLink ([], [], []) - - sortLink (a, b, OK) = (\(x, y, z) -> ((a, b):x, y, z)) - sortLink (a, b, Unparseable) = (\(x, y, z) -> (x, (a, b):y, z)) - sortLink (a, b, Broken text') = (\(x, y, z) -> (x, y, (a, b, text'):z)) - + -- Link + a text description of where that link was found in Guide allLinks :: [(Url, Text)] allLinks = ordNub (findLinks globalState) +renderOKLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderOKLinks links = do + h2_ "OK Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link", "Archival status", "Save to archive.org"] + tbody_ $ + for_ (filterOK links) $ \LinkInfo{..} -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + td_ $ renderArchivalStatus linkArchivalStatus + td_ $ button "archive" [] (JS.saveToArchiveOrg [JS.toJS linkUrl]) + where + filterOK xs = [x | x <- xs, OK <- [linkStatus x]] + +renderUnparseableLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderUnparseableLinks links = do + h2_ "Unparseable Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link"] + tbody_ $ + for_ (filterUnparseable links) $ \LinkInfo{..} -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + where + filterUnparseable xs = [x | x <- xs, Unparseable <- [linkStatus x]] + +renderBrokenLinks :: Monad m => [LinkInfo] -> HtmlT m () +renderBrokenLinks links = do + h2_ "Broken Links" + table_ [class_ "sortable"] $ do + thead_ $ tr_ $ + mapM_ th_ ["Location", "Link", "Status", "Archival status"] + tbody_ $ + for_ (filterBroken links) $ \(LinkInfo{..}, reason) -> + tr_ $ do + td_ $ toHtml linkLocation + td_ $ a_ [href_ linkUrl] (toHtml linkUrl) + td_ $ toHtml reason + td_ $ renderArchivalStatus linkArchivalStatus + where + filterBroken xs = [(x, reason) | x <- xs, Broken reason <- [linkStatus x]] + +renderArchivalStatus :: Monad m => Either String ArchivalStatus -> HtmlT m () +renderArchivalStatus = \case + Left err -> "couldn't get info from archive.org: " <> toHtml err + Right ArchivalStatus{..} + | asAvailable -> do + a_ [href_ asUrl] (toHtml (T.toStrict (dateDashF asTimestamp))) + unless (asStatus == "200") $ + toHtml (format " (status: {})" asStatus :: Text) + | otherwise -> "unavailable" + -- | Find all links in content, along with a human-readable description of -- where each link is located. findLinks :: GlobalState -> [(Url, Text)] diff --git a/src/Guide/Views/Utils.hs b/src/Guide/Views/Utils.hs index 77a0ac3..b558d2b 100644 --- a/src/Guide/Views/Utils.hs +++ b/src/Guide/Views/Utils.hs @@ -86,8 +86,6 @@ import qualified System.FilePath.Find as F -- Mustache (templates) import Text.Mustache.Plus import qualified Data.Aeson as A -import qualified Data.Aeson.Text as A -import qualified Data.Aeson.Encode.Pretty as A import qualified Data.ByteString.Lazy.Char8 as BS import qualified Data.Semigroup as Semigroup import qualified Data.List.NonEmpty as NonEmpty @@ -296,10 +294,9 @@ mustache f v = do ("selectIf", \[x] -> if x == A.Bool True then return (A.String "selected") else return A.Null), - ("js", \[x] -> return $ - A.String . T.toStrict . A.encodeToLazyText $ x), + ("js", \[x] -> return $ A.String (toJson x)), ("trace", \xs -> do - mapM_ (BS.putStrLn . A.encodePretty) xs + mapM_ (BS.putStrLn . toJsonPretty) xs return A.Null) ] widgets <- readWidgets let templates = [(tname, t) | (HTML_ tname, t) <- widgets]