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]