From 365ad1e3540b23c06b5a90bea28b996f4959cea7 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Fri, 3 Apr 2015 18:07:03 -0700 Subject: [PATCH] Only update when changes present --- src/soh-upload/Main.hs | 98 +++++++++++++++++++++++++++++++----------- 1 file changed, 73 insertions(+), 25 deletions(-) diff --git a/src/soh-upload/Main.hs b/src/soh-upload/Main.hs index b0561d3..6bdda53 100644 --- a/src/soh-upload/Main.hs +++ b/src/soh-upload/Main.hs @@ -38,6 +38,7 @@ import Network.HTTP.Types.Status (statusCode) import System.Directory (setCurrentDirectory, getDirectoryContents) import System.Environment (getArgs) +import System.IO (stdout, hSetBuffering, BufferMode (NoBuffering)) import qualified Text.HTML.DOM as Html import qualified Text.XML as Html hiding (parseLBS) @@ -66,7 +67,9 @@ data File = File { } deriving Show data SaveConfig = SaveConfig { - concurrencyToken :: ByteString + concurrencyToken :: ByteString, + oldContent :: ByteString, + oldMetadata :: Metadata Text } deriving Show data Metadata a = Metadata { @@ -262,30 +265,48 @@ metadataUpdatesFromBS bs = case parseFrontmatter bs of readFileBS :: File -> IO ByteString readFileBS File{..} = BS.readFile $ T.unpack $ fileName <> fileExtension -saveUpdate :: Context -> File -> Manager -> SaveConfig -> IO () -saveUpdate context file@File{..} manager saveConfig = do +unescape :: ByteString -> ByteString +unescape + = T.encodeUtf8 + . T.replace "&" "&" + . T.replace ">" ">" + . T.replace "<" "<" + . T.replace """ "\"" + . T.decodeUtf8 + +saveUpdate :: Context -> File -> Manager -> SaveConfig -> IO Bool +saveUpdate context file@File{..} manager saveConfig@SaveConfig{..} = do content <- readFileBS file let (metadataUpdates, content') = metadataUpdatesFromBS content content'' <- preprocessMarkdown content' - req <- postSaveReq context fileName saveConfig content'' - response <- httpLbs req manager - setMetadata context fileName metadataUpdates manager + didUpdateContent <- if (unescape content'' == oldContent) + then return False + else do + req <- postSaveReq context fileName saveConfig content'' + response <- httpLbs req manager + putStr "body uploaded... " + return True + let newMetadata = updateMetadata oldMetadata metadataUpdates + didUpdateMetadata <- if (metadataEq oldMetadata newMetadata) + then return False + else do + setMetadata context fileName metadataUpdates manager + putStr "metadata updated... " + return True + return (didUpdateContent || didUpdateMetadata) createNew :: Context -> Slug -> Manager -> IO SaveConfig createNew context slug manager = do response <- newTutorial context manager + saveConfig <- saveConfigFromLBS (responseBody response) - -- TODO: avoid the extra back and forth - oldMetadata <- htmlParseMetadata (responseBody response) - let metadataUpdates = (pure Nothing) { mdSlug = Just slug } - oldSlug = mdSlug oldMetadata - setMetadata context (mdSlug oldMetadata) metadataUpdates manager - - tokenText <- htmlParseConcurrencyToken (responseBody response) - T.putStrLn $ "Created new document: " <> slug - return $ SaveConfig { - concurrencyToken = T.encodeUtf8 tokenText - } + let freshMetadata = oldMetadata saveConfig + metadataUpdates = (pure Nothing) { mdSlug = Just slug } + freshSlug = mdSlug freshMetadata + updatedMetadata = updateMetadata freshMetadata metadataUpdates + setMetadata context freshSlug metadataUpdates manager + T.putStr $ "created... " + return saveConfig{ oldMetadata = updatedMetadata } newTutorial :: Context -> Manager -> IO (Response LBS.ByteString) newTutorial context manager = do @@ -399,18 +420,40 @@ htmlParseMetadata lbs = htmlParseOne "metadata" parsed where res -> res + +htmlParseContent :: MonadThrow m => LBS.ByteString -> m Text +htmlParseContent lbs = htmlParseOne "content" parsed where + parsed = cursor Html.$// selector + cursor = Html.fromDocument (Html.parseLBS lbs) + selector = textareaValOf (Html.attributeIs "id" "content") + + -- TODO: reduce duplication of these + -- (copied from htmlParseMetadata) + textareaValOf selector = Html.element "textarea" >=> selector + >=> childContentOr "" + childContentOr def c = case c Html.$/ Html.content of + [] -> pure def + res -> res + +saveConfigFromLBS :: MonadThrow m => LBS.ByteString -> m SaveConfig +saveConfigFromLBS lbs = do + tokenText <- htmlParseConcurrencyToken lbs + oldContentText <- htmlParseContent lbs + oldMetadata <- htmlParseMetadata lbs + return $ SaveConfig { + concurrencyToken = T.encodeUtf8 tokenText, + oldContent = T.encodeUtf8 oldContentText, + oldMetadata = oldMetadata + } + -- Discovers the concurrency token. -- Creates the tutorial first if it doesn't exist yet. getSaveConfig :: Context -> Slug -> Manager -> IO SaveConfig getSaveConfig context slug manager = do req <- getTutorialReq context slug - handle handler404 $ do response <- httpLbs req manager - tokenText <- htmlParseConcurrencyToken (responseBody response) - return $ SaveConfig { - concurrencyToken = T.encodeUtf8 tokenText - } + saveConfigFromLBS (responseBody response) where handler404 e@(StatusCodeException status _ _) = if statusCode status == 404 @@ -426,10 +469,14 @@ publishTutorial context slug manager = do uploadFile :: Context -> Manager -> File -> IO () uploadFile context manager file@File{..} = do - T.putStrLn $ "Uploading: " <> fileName - getSaveConfig context fileName manager >>= + T.putStr $ "Uploading: " <> fileName <> "... " + didUpdate <- getSaveConfig context fileName manager >>= saveUpdate context file manager - publishTutorial context fileName manager + if didUpdate + then do + publishTutorial context fileName manager + putStrLn "published." + else putStrLn "skipped." uploadAll :: Context -> [File] -> Manager -> IO () @@ -486,6 +533,7 @@ deleteAllExceptFor context@Context{..} files manager = do main = do context <- getContext files <- getFiles + hSetBuffering stdout NoBuffering withManager tlsManagerSettings $ \manager -> do uploadAll context files manager deleteAllExceptFor context files manager