1
1
mirror of https://github.com/aelve/guide.git synced 2024-12-23 04:42:24 +03:00

Merge pull request #189 from aelve/archive-links

Add archive.org data to links page
This commit is contained in:
Artyom Kazak 2017-08-20 21:56:44 +03:00 committed by GitHub
commit 5cb54f4a55
10 changed files with 253 additions and 68 deletions

2
.gitignore vendored
View File

@ -20,6 +20,8 @@ cabal.config
TAGS
.DS_Store
*~
*.swp
*.swo
*#
state/
config.json

View File

@ -63,6 +63,7 @@ library
Guide.Diff.Tokenize
Guide.Diff.Merge
Guide.Markdown
Guide.Archival
Guide.Search
Guide.JS
Guide.Views

65
src/Guide/Archival.hs Normal file
View File

@ -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
-- <http://archive.org/wayback/available?url=example.com>:
--
-- { "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{..}

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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

View File

@ -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
----------------------------------------------------------------------------

View File

@ -2,6 +2,8 @@
{-# 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 <div>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)]

View File

@ -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]