1 {-# LANGUAGE TemplateHaskell, DataKinds #-}
    2 {-# OPTIONS_GHC -fno-warn-orphans #-}
    3 module Databrary.Model.URL
    4   ( URI
    5   , validHDL
    6   , hdlURL
    7   , parseURL
    8   -- for testing
    9   , urlLink
   10   ) where
   11 
   12 import Control.Monad ((<=<), guard)
   13 import Data.Aeson (ToJSON(..))
   14 import Data.Char (isDigit)
   15 import Data.Maybe (fromMaybe, isNothing)
   16 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..))
   17 import Language.Haskell.TH.Lift (deriveLiftMany)
   18 import Network.URI
   19 import qualified Text.Blaze as H
   20 
   21 import qualified Databrary.Store.Config as C
   22 
   23 -- | Prepare a URI value for using in a query or storing in a table
   24 toPG :: URI -> String
   25 toPG u = uriToString id u ""
   26 
   27 -- | Extract a URI value, after it has been retrieved using a query
   28 fromPG :: String -> URI
   29 fromPG u = fromMaybe (error $ "pgDecode URI: " ++ u) $ parseURI u
   30 
   31 -- | From URI value into value to be provided to database
   32 instance PGParameter "text" URI where
   33   pgEncode t = pgEncode t . toPG
   34   pgEncodeValue e t = pgEncodeValue e t . toPG
   35   pgLiteral t = pgLiteral t . toPG
   36 -- | From database value to URI value
   37 instance PGColumn "text" URI where
   38   pgDecode t = fromPG . pgDecode t
   39   pgDecodeValue e t = fromPG . pgDecodeValue e t
   40 
   41 -- | Format a URL value for inclusion in a JSON object
   42 instance ToJSON URI where
   43   toJSON = toJSON . show
   44 
   45 -- | Extract a URI value from a configuration entry
   46 instance C.Configurable URI where
   47   config = parseAbsoluteURI <=< C.config
   48 
   49 -- | Format a URI for display in a server side generated html page
   50 instance H.ToValue URI where
   51   toValue = H.stringValue . show . urlLink
   52   preEscapedToValue = H.preEscapedStringValue . show . urlLink
   53 
   54 -- | A valid HDL handle consists of digits with periods interleaved, ending with a slash (following by anything).
   55 -- See handle.net for more information. What is generating and using HDL urls?
   56 validHDL :: String -> Bool
   57 validHDL = v0 (0 :: Int) where
   58   v0 n (c:s) | isDigit c = v1 n s
   59   v0 _ _ = False
   60   v1 n ('/':_) = n > 0
   61   v1 n ('.':s) = v0 (succ n) s
   62   v1 n s = v0 n s
   63 
   64 -- | Build an HDL url from a DOI
   65 hdlURL :: String -> URI
   66 hdlURL doi = URI "hdl:" Nothing doi "" ""
   67 
   68 -- | Start from either a shorthand DOI value or a doi/hdl scheme or doi domain, and
   69 -- expand out to canonical HDL based URI. For all other http/https URLs, pass value through
   70 parseURL :: String -> Maybe URI
   71 parseURL d@('1':'0':'.':c:_) | isDigit c = parseURL $ "doi:" ++ d
   72 parseURL s = do
   73   u <- parseURI s
   74   if uriScheme u `elem` ["doi:","hdl:"] && isNothing (uriAuthority u) ||
   75      uriScheme u == "http:"
   76        && (uriAuthority u == Just (URIAuth "" "dx.doi.org" "") || uriAuthority u == Just (URIAuth "" "doi.org" ""))
   77     then do
   78       let p = dropWhile ('/' ==) $ uriPath u
   79       guard $ validHDL p
   80       return u
   81         { uriScheme = "hdl:"
   82         , uriAuthority = Nothing
   83         , uriPath = p
   84         }
   85     else do
   86       guard $ uriScheme u `elem` ["http:","https:"]
   87       return u
   88 
   89 -- | Utility for building a URI value from a domain and path
   90 httpAuth :: String -> URI -> URI
   91 httpAuth a u = u{ uriScheme = "http:", uriAuthority = Just (URIAuth "" a ""), uriPath = '/':uriPath u }
   92 
   93 -- | Expand special doi and hdl scheme URIs to equivalent http scheme URIs.
   94 -- Allow http URIs to pass through
   95 urlLink :: URI -> URI
   96 urlLink u@URI{ uriScheme = "hdl:" } = httpAuth "hdl.handle.net" u
   97 urlLink u@URI{ uriScheme = "doi:" } = httpAuth "doi.org" u
   98 urlLink u = u
   99 
  100 deriveLiftMany [''URIAuth, ''URI]