cap gallery images to 2000px

make-pages/SinglePage.hs

@@ -12,9 +12,7 @@ import Data.List (sort)
 import Data.Maybe (fromMaybe)
 import qualified Data.Text as Strict
 import qualified Data.Text.Lazy as Lazy
-import System.FilePath (joinPath, splitPath, (</>))
-import qualified System.Process as Proc
-import Text.Read (readMaybe)
+import System.FilePath (joinPath, splitPath)
 import qualified Data.HashSet as Set
 import Data.Traversable
 
@@ -39,8 +37,8 @@ make root prefix nsfw dataDir dir info =
   toLazyText <$> make' root prefix nsfw dataDir dir info
 
 make' :: Text -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder
-make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
-  images <- withSizes (dataDir </> dir) $ imagesFor nsfw info
+make' root prefix nsfw _dataDir dir info@(Info {date, title, artist, bg}) = do
+  let images = imagesFor nsfw info
 
   let undir = joinPath (replicate (length (splitPath dir)) "..")
 
@@ -49,12 +47,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
   let formattedDate = formatLong date
 
   let buttonBar = makeButtonBar title $ addIds images
-  let (image0@(Image {path = path0, download = download0'}),
-       Size {width = width0, height = height0}) : otherImages
-        = #all images
-  let download0 = fromMaybe path0 download0'
+  let image0@(Image {path = path0, download = download0'}) : otherImages =
+        #all images
+  let download0 = fromMaybe (bigFile path0) download0'
   let path0'    = pageFile path0
-  let tinyCls   = if any (tiny . #second) images then [b| class=tiny|] else ""
 
   let descSection = makeDesc $ descFor nsfw info
   let tagsList    = makeTags undir $ tagsFor nsfw info
@@ -62,8 +58,9 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
   let updates     = sort $ updatesFor nsfw info
   let updatesList = makeUpdates updates
 
-  let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path>|]
-  let prefetches = map (makePrefetch . #first) otherImages
+  let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path'>|]
+        where path' = bigFile path
+  let prefetches = map makePrefetch otherImages
 
   let makeWarning w = [b|@0
         <figcaption id=cw aria-role=button tabindex=0>
@@ -136,7 +133,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
       $2.buttonBar
 
       <main>
-        <figure id=mainfig data-width=$width0 data-height=$height0$tinyCls>
+        <figure id=mainfig>
           $warning'
           <a id=mainlink href="$download0" title="download full version">
             <img id=mainimg src="$path0'" alt="">
@@ -199,14 +196,14 @@ makeDesc (LongDesc fs) = [b|@0
       </div>
     |]
 
-addIds :: Traversable t => t (Image, a) -> t (Image, a, Text)
+addIds :: Traversable t => t Image -> t (Image, Text)
 addIds = snd . mapAccumL makeId Set.empty where
-  makeId used (img, x) = (Set.insert newId used, (img, x, newId)) where
+  makeId used img = (Set.insert newId used, (img, newId)) where
     newId = head $ filter (\i -> not $ i `Set.member` used) ids
     ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]]
     label = escId $ #label img
 
-makeButtonBar :: Strict.Text -> Images' (Image, Size, Text) -> Builder
+makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
 makeButtonBar title images =
   case images of
     Uncat []        -> throw $ NoEligibleImages title
@@ -233,27 +230,25 @@ makeButtonBar title images =
         <ul class="buttonbar bb-choice">
           $2.elems
         </ul> |]
-     where elems = map (\(img,sz,i) -> altButton img sz i) imgs
+     where elems = map (\(img,i) -> altButton img i) imgs
 
-flatten :: [(Text, [(Image, Size, Text)])] -> [(Image, Size, Text)]
+flatten :: [(Text, [(Image, a)])] -> [(Image, Text)]
 flatten cats =
-  addIds [(img {label = cat}, sz) | (cat, is) <- cats, (img, sz, _) <- is]
+  addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is]
 
-altButton :: Image -> Size -> Text -> Builder
-altButton img size i = [b|@0
+altButton :: Image -> Text -> Builder
+altButton img i = [b|@0
   <li$nsfwClass>
     <input type=radio name=variant id="$i" value="$path'"
-           data-link="$link"$warning'
-           data-width=$width data-height=$height>
+           data-link="$link"$warning'>
     <label for="$i"$nsfwLabelClass>$label</label>
   |]
  where
   Image {label, path, nsfw, warning, download} = img
-  Size {width, height} = size
   nsfwClass      = if nsfw then [b| class=nsfw|]       else ""
   nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
   path'          = pageFile path
-  link           = fromMaybe path download
+  link           = fromMaybe (bigFile path) download
   warning'       = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
 
 makeTags :: FilePath -> [Strict.Text] -> Builder
@@ -309,23 +304,3 @@ makeUpdate (Update {date, desc}) = [b|@8
     <dd>$desc
   |]
   where date' = formatSlash date
-
-data Size = Size {width, height :: !Int} deriving (Eq, Show)
-
-tiny :: Size -> Bool
-tiny (Size {width, height}) = width < 250 || height < 250
-
-imageSize :: FilePath -> FilePath -> IO Size
-imageSize dir img = do
-  -- "[0]" to get the first frame of an animation
-  -- otherwise it prints a pair for each frame
-  let filename = (dir </> img) ++ "[0]"
-  output <- Proc.readProcess "identify" ["-format", "(%W,%H)", filename] ""
-  case readMaybe output of
-    Just (width, height) -> pure $ Size {width, height}
-    Nothing -> fail $ "couldn't understand identify output:\n" ++ output
-
-withSizes :: Traversable t => FilePath -> t Image -> IO (t (Image, Size))
-withSizes dir = traverse \img -> do
-  size <- imageSize dir $ #path img
-  pure (img, size)