summaryrefslogtreecommitdiff
path: root/Database/Types.hs
blob: f08cf4e9d8efa9c5e985540d0213ff0a34993ee6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
{- types for SQL databases
 -
 - Copyright 2015-2019 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Database.Types where

import Database.Persist.TH
import Database.Persist.Class hiding (Key)
import Database.Persist.Sql hiding (Key)
import Data.Maybe
import Data.Char
import qualified Data.ByteString as S
import qualified Data.Text as T

import Utility.PartialPrelude
import Key
import Utility.InodeCache
import Git.Types (Ref(..))
import Types.UUID
import Types.Import

-- A serialized Key
newtype SKey = SKey String
	deriving (Show, Read)

toSKey :: Key -> SKey
toSKey = SKey . serializeKey

fromSKey :: SKey -> Key
fromSKey (SKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s)

derivePersistField "SKey"

-- A Key index. More efficient than SKey, but its Read instance does not
-- work when it's used in any kind of complex data structure.
newtype IKey = IKey String

instance Read IKey where
	readsPrec _ s = [(IKey s, "")]

instance Show IKey where
	show (IKey s) = s

toIKey :: Key -> IKey
toIKey = IKey . serializeKey

fromIKey :: IKey -> Key
fromIKey (IKey s) = fromMaybe (error $ "bad serialized Key " ++ s) (deserializeKey s)

derivePersistField "IKey"

-- A serialized InodeCache
newtype SInodeCache = I String
	deriving (Show, Read)

toSInodeCache :: InodeCache -> SInodeCache
toSInodeCache = I . showInodeCache

fromSInodeCache :: SInodeCache -> InodeCache
fromSInodeCache (I s) = fromMaybe (error $ "bad serialized InodeCache " ++ s) (readInodeCache s)

derivePersistField "SInodeCache"

-- A serialized FilePath.
--
-- Not all unicode characters round-trip through sqlite. In particular,
-- surrigate code points do not. So, escape the FilePath. But, only when
-- it contains such characters.
newtype SFilePath = SFilePath String

-- Note that Read instance does not work when used in any kind of complex
-- data structure.
instance Read SFilePath where
	readsPrec _ s = [(SFilePath s, "")]

instance Show SFilePath where
	show (SFilePath s) = s

toSFilePath :: FilePath -> SFilePath
toSFilePath s@('"':_) = SFilePath (show s)
toSFilePath s
	| any needsescape s = SFilePath (show s)
	| otherwise = SFilePath s
  where
	needsescape c = case generalCategory c of
		Surrogate -> True
		PrivateUse -> True
		NotAssigned -> True
		_ -> False

fromSFilePath :: SFilePath -> FilePath
fromSFilePath (SFilePath s@('"':_)) =
	fromMaybe (error "bad serialized SFilePath " ++ s) (readish s)
fromSFilePath (SFilePath s) = s

derivePersistField "SFilePath"

-- A serialized Ref
newtype SRef = SRef Ref

-- Note that Read instance does not work when used in any kind of complex
-- data structure.
instance Read SRef where
	readsPrec _ s = [(SRef (Ref s), "")]

instance Show SRef where
	show (SRef (Ref s)) = s

derivePersistField "SRef"

toSRef :: Ref -> SRef
toSRef = SRef

fromSRef :: SRef -> Ref
fromSRef (SRef r) = r

instance PersistField UUID where
	toPersistValue u = toPersistValue b
	  where
		b :: S.ByteString
		b = fromUUID u
	fromPersistValue v = toUUID <$> go
	  where
	 	go :: Either T.Text S.ByteString
		go = fromPersistValue v

instance PersistFieldSql UUID where
	sqlType _ = SqlBlob

instance PersistField ContentIdentifier where
	toPersistValue (ContentIdentifier b) = toPersistValue b
	fromPersistValue v = ContentIdentifier <$> go
	  where
	 	go :: Either T.Text S.ByteString
		go = fromPersistValue v

instance PersistFieldSql ContentIdentifier where
	sqlType _ = SqlBlob