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