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]