Add an option for mess-html for cache direcotyr

Author: gnull

app/html/Main.hs

@@ -1,19 +1,26 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 module Main where
 
-import Prelude hiding (readFile, writeFile)
+import Prelude hiding (writeFile)
 
 import Data.List (sortBy)
 import Data.Ord (comparing)
 import Control.Monad (forM_)
+import Control.Monad.Writer (runWriter)
+import Control.Arrow (second)
 import Data.Binary (decode)
 
+import System.FilePath ((</>))
+
 import Data.VkMess
   ( Snapshot(..)
   , readFile
   , writeFile
   , mDate
+  , listToWriter
+  , replaceSnapshotUrls
   )
 
 import Options.Applicative
@@ -28,20 +35,39 @@ import Text.Html.VkMess
   , standalone
   )
 
-optparser :: IO FilePath
+data Options = Options
+  { inFile :: FilePath
+  , cacheDir :: Maybe FilePath
+  }
+
+sample :: Parser Options
+sample = do
+  inFile <- argument str $
+              metavar "DUMP"
+           <> help "Input file"
+  cacheDir <- optional $ strOption $
+              long "cache"
+           <> short 'c'
+           <> help "Directory containing cache produced by mess-cache"
+  pure $ Options {..}
+
+optparser :: IO Options
 optparser = execParser opts
   where
-    opts = info (inFile <**> helper)
+    opts = info (sample <**> helper)
       ( fullDesc
      <> progDesc "Render messages fetched by mess-fetch as html")
-    inFile = argument str $
-              metavar "FILE"
-           <> help "Input file"
 
 main :: IO ()
 main = do
-  inFile <- optparser
-  (Snapshot ms self users chats) <- decode <$> readFile inFile
+  Options {..} <- optparser
+  mm <- case cacheDir of
+    Just d -> listToWriter <$> map (second (d </>)) <$> map (\[k, v] -> (k, v))
+          <$> map words <$> lines <$> Prelude.readFile (d </> "index.txt")
+    Nothing -> pure pure
+  (Snapshot ms self users chats) <- fst <$> runWriter
+    <$> replaceSnapshotUrls mm
+    <$> decode <$> Data.VkMess.readFile inFile
   writeFile "index.html" $ renderHtml $ mainHtml users chats self ms
   writeFile "messages.html" $ renderHtml $ standalone "All messages"
                             $ messagesHtml users self

package.yaml

@@ -10,6 +10,7 @@ extra-source-files:
 - README.md
 dependencies:
 - base >=4.7 && <5
+- mtl >=2.2 && <3
 - text >=1.2 && <2
 - unix-time >=0.3 && <1
 - aeson >=1.1 && <2

src/Data/VkMess.hs

@@ -16,6 +16,8 @@ module Data.VkMess
   , Conversation(..), Conversations(..)
   , convTitle, convExtId
   , getSnapshotUrls
+  , replaceSnapshotUrls
+  , listToWriter
   ) where
 
 import Prelude hiding (readFile, writeFile)
@@ -29,12 +31,16 @@ import Data.Maybe (fromMaybe, fromJust, catMaybes)
 import Data.Bool (bool)
 import Data.Monoid (Sum(..))
 
+import Control.Monad.Writer (Writer, tell)
+
 -- For deriving Monod instances
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
 import Data.Foldable (toList)
 import Data.Set (Set, singleton, fromList)
-import Data.List (sort)
+import Data.List (sort, maximumBy, deleteBy)
+import Data.Ord (comparing)
+import Data.Function (on)
 import Control.Monad (forM, liftM)
 import Data.Text (Text, pack)
 import Data.UnixTime (fromEpochTime, UnixTime)
@@ -233,3 +239,30 @@ getSnapshotUrls (Snapshot {..})
     attachmentUrls (Link _ _ _) = []
     attachmentUrls (AudioMsg x) = [x]
     attachmentUrls (Other _) = []
+
+listToWriter :: [(FilePath, FilePath)] -> FilePath -> Writer [FilePath] FilePath
+listToWriter xs k = case lookup k xs of
+  Just x -> pure x
+  Nothing -> tell [k] >> pure k
+
+replaceSnapshotUrls :: (FilePath -> Writer [FilePath] FilePath) -> Snapshot -> Writer [FilePath] Snapshot
+replaceSnapshotUrls m ss = do
+    sDialogs' <- forM (sDialogs ss) $ \(conv, ms) -> do
+      conv' <- replaceConv conv
+      ms' <- mapM replaceMessage ms
+      pure (conv', ms')
+    pure $ ss { sDialogs = sDialogs' }
+  where
+    replaceConv (ConvUser i n p) = ConvUser i n <$> m p
+    replaceConv x = pure x
+    replaceMessage ms = do
+      fwd <- mapM replaceMessage $ mFwd ms
+      att <- mapM replaceAtt $ mAtt ms
+      pure $ ms { mFwd = fwd, mAtt = att }
+    replaceAtt (Photo x) = do
+      let (i, v) = maximumBy (comparing fst) x
+      v' <- m v
+      pure $ Photo $ (i, v') : deleteBy ((==) `on` fst) (i, undefined) x
+    replaceAtt (Sticker x) = Sticker <$> m x
+    replaceAtt (AudioMsg x) = AudioMsg <$> m x
+    replaceAtt x = pure x