1 {-# LANGUAGE OverloadedStrings, RecordWildCards, ScopedTypeVariables #-} 2 module 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 Ops 21 import Has (view) 22 import Service.Messages 23 import Store.Filename 24 import Model.Time 25 import Model.Enum 26 import Model.Release.Types 27 import Model.Id.Types 28 import Model.Party 29 import Model.Volume.Types 30 import Model.Container 31 import Model.Segment 32 import Model.Slot.Types 33 import Model.Citation.Types 34 import Model.Funding.Types 35 import Model.RecordSlot.Types 36 import Model.Record.Types 37 import Model.Category.Types 38 import Model.Measure 39 import Model.Metric.Types 40 import Model.Asset.Types 41 import Model.AssetSlot.Types 42 import Model.Format 43 import Action 44 import Controller.Paths 45 import Controller.Volume 46 import Controller.Party 47 import Controller.Container 48 import Controller.Asset 49 import Controller.Web 50 import Controller.IdSet 51 import View.Html 52 53 -- import {-# SOURCE #-} 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