1 {-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} 2 module Databrary.View.Zip 3 ( htmlVolumeDescription 4 ) where 5 6 import Control.Monad (void, unless, forM_) 7 import qualified Data.ByteString.Builder as BSB 8 import qualified Data.ByteString.Char8 as BSC 9 import Data.Char (toLower) 10 import Data.Maybe (fromMaybe) 11 import Data.Monoid ((<>)) 12 import Data.String (fromString) 13 import Data.Time.Format (formatTime, defaultTimeLocale) 14 import System.FilePath ((<.>)) 15 import System.Posix.FilePath ((</>)) 16 import qualified Text.Blaze.Html5 as H 17 import qualified Text.Blaze.Html5.Attributes as HA 18 import qualified Text.Blaze.Html4.Strict.Attributes as H4A 19 20 import Databrary.Ops 21 import Databrary.Has (view) 22 import Databrary.Service.Messages 23 import Databrary.Store.Filename 24 import Databrary.Model.Time 25 import Databrary.Model.Enum 26 import Databrary.Model.Release.Types 27 import Databrary.Model.Id.Types 28 import Databrary.Model.Party 29 import Databrary.Model.Volume.Types 30 import Databrary.Model.Container 31 import Databrary.Model.Segment 32 import Databrary.Model.Slot.Types 33 import Databrary.Model.Citation.Types 34 import Databrary.Model.Funding.Types 35 import Databrary.Model.RecordSlot.Types 36 import Databrary.Model.Record.Types 37 import Databrary.Model.Category.Types 38 import Databrary.Model.Measure 39 import Databrary.Model.Metric.Types 40 import Databrary.Model.Asset.Types 41 import Databrary.Model.AssetSlot.Types 42 import Databrary.Model.Format 43 import Databrary.Action 44 import Databrary.Controller.Paths 45 import Databrary.Controller.Volume 46 import Databrary.Controller.Party 47 import Databrary.Controller.Container 48 import Databrary.Controller.Asset 49 import Databrary.Controller.Web 50 import Databrary.Controller.IdSet 51 import Databrary.View.Html 52 53 -- import {-# SOURCE #-} Databrary.Controller.Zip 54 55 htmlVolumeDescription :: Bool -> Volume -> [Citation] -> [Funding] -> [RecordSlot] -> IdSet Container -> [[AssetSlot]] -> [[AssetSlot]] -> RequestContext -> H.Html 56 htmlVolumeDescription inzip Volume{ volumeRow = VolumeRow{..}, ..} cite fund glob cs atl abl req = H.docTypeHtml $ do 57 H.head $ do 58 H.meta H.! HA.httpEquiv "content-type" H.! HA.content "text/html;charset=utf-8" 59 H.title $ do 60 void "Databrary Volume " 61 H.toMarkup (unId volumeId) 62 H.body $ do 63 H.p $ do 64 H.em "Databrary" 65 void " Volume " 66 H.toMarkup (unId volumeId) 67 forM_ volumeDOI $ \doi -> do 68 void " DOI " 69 byteStringHtml doi 70 H.h1 $ 71 H.a H.! HA.href (maybe (link viewVolume (HTML, volumeId)) (byteStringValue . ("http://doi.org/" <>)) volumeDOI) $ 72 H.text volumeName 73 H.ul $ forM_ volumeOwners $ \(i, n) -> 74 H.li $ 75 H.a H.! HA.href (link viewParty (HTML, TargetParty i)) $ 76 H.text n 77 H.h2 "Volume description" 78 mapM_ (H.p . H.text) volumeBody 79 unless (null fund) $ do 80 H.h3 "Funded by" 81 H.dl $ forM_ fund $ \Funding{..} -> do 82 H.dt $ H.text $ funderName fundingFunder 83 mapM_ (H.dd . H.text) fundingAwards 84 unless (null cite) $ do 85 H.h3 "Related works" 86 H.ul $ forM_ cite $ \Citation{..} -> H.li $ 87 maybe id (\u -> H.a H.! HA.href (H.toValue u)) citationURL $ do 88 H.text citationHead 89 forM_ citationYear $ \y -> 90 " (" >> H.toMarkup (fromIntegral y :: Int) >> ")" 91 unless (null glob) $ do 92 H.h3 "Descriptors" 93 forM_ glob $ \RecordSlot{ slotRecord = r, recordSlot = s } -> do 94 H.h3 $ H.text $ categoryName $ recordCategory $ recordRow r 95 H.dl $ do 96 unless (segmentFull $ slotSegment s) $ do 97 H.dt "segment" 98 H.dd $ H.string $ show $ slotSegment s 99 forM_ (getRecordMeasures r) $ \m -> do 100 H.dt $ H.text $ metricName $ measureMetric m 101 H.dd $ byteStringHtml $ measureDatum m 102 H.h2 "Package information" 103 H.dl $ do 104 H.dt "Created" 105 H.dd $ H.string $ formatTime defaultTimeLocale "%d %b %Y" volumeCreation 106 -- if inzip 107 -- then do 108 do 109 H.dt "Downloaded" 110 H.dd $ do 111 H.string $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" (view req :: Timestamp) 112 void " by " 113 H.a H.! HA.href (link viewParty (HTML, TargetParty $ view req)) $ 114 H.text $ partyName $ partyRow $ view req 115 -- else do 116 -- H.dt $ H.a H.! actionLink (zipVolume True) volumeId (idSetQuery cs) $ 117 -- void "Download Original" 118 unless (idSetIsFull cs) $ H.p $ msg "download.zip.partial" 119 H.p $ do 120 msg "download.warning" 121 void " For more information and terms of use see the " 122 H.a H.! HA.href "http://databrary.org/access/policies/agreement.html" 123 $ "Databrary Access Agreement" 124 void "." 125 H.h2 "Contents" 126 H.h3 "Legend of release levels" 127 H.dl $ forM_ pgEnumValues $ \(_ :: Release, n) -> do 128 H.dt $ H.string n 129 H.dd $ do 130 H.img H.! HA.src (link webFile (Just $ staticPath ["icons", "release", BSC.pack $ map toLower n <.> "svg"])) 131 msg (fromString $ "release." ++ n ++ ".title") 132 void ": " 133 msg (fromString $ "release." ++ n ++ ".description") 134 H.h3 "Materials" 135 atable atl 136 H.h3 "Sessions" 137 atable abl 138 where 139 link r a = builderValue $ actionURL (inzip `thenUse` (view req)) r a [] 140 msg m = H.text $ getMessage m $ view req 141 atable acl = H.table H.! H4A.border "1" $ do 142 H.thead $ H.tr $ do 143 H.th "directory" 144 H.th "container" 145 H.th "file" 146 H.th "description" 147 H.th "release" 148 H.th "size" 149 H.th "duration" 150 H.th "sha1 checksum" 151 H.tbody $ abody acl 152 abody [] = mempty 153 abody (~(AssetSlot{ assetSlot = Nothing }:_):_) = mempty 154 -- FIXME, probably don't want lazy patterns since all this beautiful code 155 -- never evaluates. 156 abody (~(a@AssetSlot{ assetSlot = Just Slot{ slotContainer = c } }:l):al) = do 157 H.tr $ do 158 H.td H.! rs $ H.a !? (inzip `thenUse` (HA.href (byteStringValue fn))) $ 159 byteStringHtml dn 160 H.td H.! rs $ H.a H.! HA.href (link viewContainer (HTML, (Just volumeId, containerId $ containerRow c))) $ do 161 mapM_ H.string $ formatContainerDate c 162 mapM_ H.text $ containerName $ containerRow c 163 arow fn a 164 mapM_ (H.tr . arow fn) l 165 abody al 166 where 167 rs = HA.rowspan $ H.toValue $ succ $ length l 168 dn = makeFilename $ containerDownloadName c 169 fn 170 | containerTop (containerRow c) = dn 171 | otherwise = "sessions" </> dn 172 arow bf as@AssetSlot{ slotAsset = Asset{ assetRow = a } } = do 173 H.td $ H.a !? (inzip `thenUse` (HA.href (byteStringValue $ bf </> fn))) $ 174 byteStringHtml fn 175 H.td $ H.a H.! HA.href (link viewAsset (HTML, assetId a)) $ 176 H.text $ fromMaybe (formatName $ assetFormat a) $ assetName a 177 H.td $ H.string $ show (getAssetSlotRelease as :: Release) 178 H.td $ maybe mempty H.toMarkup $ assetSize a 179 H.td $ maybe mempty (H.string . show) $ assetDuration a 180 H.td $ maybe mempty (lazyByteStringHtml . BSB.toLazyByteString . BSB.byteStringHex) $ assetSHA1 a 181 where 182 fn = last $ BSC.split '-' $ makeFilename (assetDownloadName True False a) `addFormatExtension` assetFormat a