-
Notifications
You must be signed in to change notification settings - Fork 2
/
ImageCodesProducer.hs
126 lines (110 loc) · 4.68 KB
/
ImageCodesProducer.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings, LambdaCase #-}
module ImageCodesProducer
( compileImageInfo
, prepareImageDb
, ImagesDb
) where
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Control.Applicative
import Control.Concurrent.ParallelIO.Local
import Control.Monad.Extra
import Data.Char
import Data.List
import Data.String.Interpolate.IsString
import GHC.Generics
import System.Directory
import System.Process
import Text.Pandoc.Definition(Inline(..))
data ImgAlign = AlignLeft | AlignRight | AlignInline
deriving (Eq, Ord, Show)
instance A.FromJSON ImgAlign where
parseJSON o = textParser o <|> pure AlignInline
where textParser = A.withText "ImgAlign" $
\case "left" -> pure AlignLeft
"right" -> pure AlignRight
"inline" -> pure AlignInline
t -> fail [i|Unknown alignment: #{t}|]
data ThumbSize = ThumbSmall | ThumbMedium | ThumbLarge
deriving (Eq, Ord, Show, Enum, Bounded)
instance A.FromJSON ThumbSize where
parseJSON = A.withText "ThumbSize" $ \case "small" -> pure ThumbSmall
"medium" -> pure ThumbMedium
"large" -> pure ThumbLarge
t -> fail [i|Unknown thumb size: #{t}|]
data ImageRefInfo = ImageRefInfo
{ title :: String
, name :: String
, thumb :: Maybe ThumbSize
, align :: ImgAlign
} deriving (Eq, Ord, Show, Generic, A.FromJSON)
compileImageInfo :: ImagesDb -> T.Text -> Inline
compileImageInfo db str | Left err <- decoded = error $ "Unable to decode image info: " <> err
| Right ii <- decoded = producePandoc db ii
where decoded = A.eitherDecodeStrict $ T.encodeUtf8 str
producePandoc :: ImagesDb -> ImageRefInfo -> Inline
producePandoc ImagesDb { .. } ImageRefInfo { .. } = RawInline "html" fullHtml
where
origDims' = origDims $ images HM.! name
(imgPath, (width, height)) = case thumb of
Just thumbTy -> (thumbDirName thumbTy, scale origDims' thumbTy)
Nothing -> ("", origDims')
fullHtml = [i|
<div class="img-wrap img-wrap-#{drop 5 $ toLower <$> show align}">
<a href="/#{rootPath}/#{name}">
<img src="/#{rootPath}/#{imgPath}/#{name}" width="#{width}" height="#{height}" alt="#{title}" title="#{title}" /><br/>
<strong>#{title}</strong>
</a>
</div>
|]
thumbDirName :: ThumbSize -> String
thumbDirName thumbTy = drop 5 $ toLower <$> show thumbTy
thumbWidth :: ThumbSize -> Int
thumbWidth = \case ThumbSmall -> 220
ThumbMedium -> 440
ThumbLarge -> 800
scale :: (Int, Int) -> ThumbSize -> (Int, Int)
scale (w, h) thumbTy = (targetW, round' $ fromIntegral (h * targetW) / (fromIntegral w :: Double))
where
targetW = thumbWidth thumbTy
round' v | v - fromIntegral (floor v :: Int) == 0.5 = ceiling v
| otherwise = round v
data DiskImageInfo = DiskImageInfo
{ origPath :: String
, origDims :: (Int, Int)
} deriving (Eq, Ord, Show)
data ImagesDb = ImagesDb
{ rootPath :: String
, images :: HM.HashMap String DiskImageInfo
} deriving (Eq, Ord, Show)
prepareImageDb :: String -> IO ImagesDb
prepareImageDb rootPath = do
fileNames <- filter isOrigImage <$> listDirectory rootPath
compileThumbnails rootPath fileNames
let files = (rootPath <>) <$> fileNames
output <- readProcess "identify" (["-format", "%w %h\n"] <> files) ""
let filesDims = parseDims <$> lines output
let images = HM.fromList [ (name, DiskImageInfo { .. })
| (name, origPath, origDims) <- zip3 fileNames files filesDims
]
pure ImagesDb { .. }
where
isOrigImage name = ".png" `isSuffixOf` name
&& not ("hakyllthumb" `isInfixOf` name)
parseDims line | [w, h] <- words line = (read w, read h)
| otherwise = error $ "Unable to parse " <> line
compileThumbnails :: String -> [String] -> IO ()
compileThumbnails rootPath names = do
forM_ thumbs $ \thumb -> createDirectoryIfMissing False $ rootPath <> thumbDirName thumb
void $ withPool 10 $ \pool -> parallel pool [ f name thumb | name <- names , thumb <- thumbs ]
where
thumbs = [minBound .. maxBound]
f name thumb = do
let inFile = rootPath <> name
let outFile = rootPath <> thumbDirName thumb <> "/" <> name
unlessM (doesFileExist outFile) $ do
putStrLn $ "Generating thumbnail for " <> outFile
callProcess "convert" [inFile, "-resize", show $ thumbWidth thumb, outFile]