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