1 {-# LANGUAGE TemplateHaskell, DataKinds #-} 2 module Databrary.Model.ORCID 3 ( ORCID(..) 4 , blankORCID 5 , orcidURL 6 ) where 7 8 import Control.Monad (guard) 9 import qualified Data.ByteString.Char8 as BSC 10 import Data.Char (isDigit, digitToInt, intToDigit) 11 import Data.List (foldl') 12 import Database.PostgreSQL.Typed.Types (PGParameter(..), PGColumn(..)) 13 import Instances.TH.Lift () 14 import Language.Haskell.TH.Lift (deriveLift) 15 import qualified Network.URI as URI 16 import qualified Text.ParserCombinators.ReadP as RP 17 import qualified Text.ParserCombinators.ReadPrec as RP (lift) 18 import Text.Read (Read(readPrec)) 19 20 newtype ORCID = ORCID { orcid :: BSC.ByteString } -- deriving (Eq) 21 22 instance PGParameter "bpchar" ORCID where 23 pgEncode t = pgEncode t . orcid 24 pgEncodeValue e t = pgEncodeValue e t . orcid 25 pgLiteral t = pgLiteral t . orcid 26 instance PGColumn "bpchar" ORCID where 27 pgDecode t = ORCID . pgDecode t 28 pgDecodeValue e t = ORCID . pgDecodeValue e t 29 instance PGColumn "character varying" ORCID where 30 pgDecode t = ORCID . pgDecode t 31 pgDecodeValue e t = ORCID . pgDecodeValue e t 32 33 34 deriveLift ''ORCID 35 36 checksumDigit :: Int -> Char 37 checksumDigit 10 = 'X' 38 checksumDigit i = intToDigit i 39 40 instance Show ORCID where 41 show (ORCID s) = group $ BSC.unpack s where 42 group (a:b:c:d:r@(_:_)) = a:b:c:d:'-':group r 43 group r = r 44 45 instance Read ORCID where 46 readPrec = RP.lift $ do 47 RP.skipSpaces 48 RP.optional $ RP.string "http://" 49 RP.optional $ RP.string "orcid.org/" 50 b <- RP.count 15 $ do 51 RP.optional $ RP.char '-' 52 RP.satisfy isDigit 53 RP.optional $ RP.char '-' 54 c <- RP.satisfy (\c -> 'X' == c || isDigit c) 55 guard $ checksumDigit (10 - (9 + foldl' (\s -> (*) 2 . (+) s . digitToInt) 0 b) `mod` 11) == c 56 return $ ORCID $ BSC.snoc (BSC.pack b) c 57 58 blankORCID :: ORCID 59 blankORCID = ORCID BSC.empty -- "0000000000000001" 60 61 orcidURL :: ORCID -> URI.URI 62 orcidURL o = URI.nullURI 63 { URI.uriScheme = "http:" 64 , URI.uriAuthority = Just URI.URIAuth 65 { URI.uriUserInfo = "" 66 , URI.uriRegName = "orcid.org" 67 , URI.uriPort = "" 68 } 69 , URI.uriPath = '/' : show o 70 }