diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2022-05-26 13:58:07 +0200 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2022-05-26 13:58:07 +0200 |
commit | fc6cf6169868e60c189e4b243330c3717ff159f3 (patch) | |
tree | 3f6dea9c1420e23756257b5abea27ec9ed92d58a /overlays/spm/server | |
parent | 84f2affd66a0ff3947b91a30308cb8e6a8ff7594 (diff) | |
download | nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.gz nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.bz2 nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.tar.xz nixos-fc6cf6169868e60c189e4b243330c3717ff159f3.zip |
...
Diffstat (limited to 'overlays/spm/server')
-rw-r--r-- | overlays/spm/server/Crypto/JOSE/JWK/Instances.hs | 9 | ||||
-rw-r--r-- | overlays/spm/server/Crypto/Random/Instances.hs | 27 | ||||
-rw-r--r-- | overlays/spm/server/Data/CaseInsensitive/Instances.hs | 30 | ||||
-rw-r--r-- | overlays/spm/server/Data/UUID/Instances.hs | 31 | ||||
-rw-r--r-- | overlays/spm/server/Spm/Server.hs | 271 | ||||
-rw-r--r-- | overlays/spm/server/Spm/Server/Ctx.hs | 24 | ||||
-rw-r--r-- | overlays/spm/server/Spm/Server/Database.hs | 73 | ||||
-rw-r--r-- | overlays/spm/server/Spm/Server/UI.hs | 23 | ||||
-rw-r--r-- | overlays/spm/server/Spm/Server/Wordlist.hs | 31 |
9 files changed, 519 insertions, 0 deletions
diff --git a/overlays/spm/server/Crypto/JOSE/JWK/Instances.hs b/overlays/spm/server/Crypto/JOSE/JWK/Instances.hs new file mode 100644 index 00000000..44a5cfe0 --- /dev/null +++ b/overlays/spm/server/Crypto/JOSE/JWK/Instances.hs | |||
@@ -0,0 +1,9 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
3 | |||
4 | module Crypto.JOSE.JWK.Instances () where | ||
5 | |||
6 | import Control.Lens.TH | ||
7 | import Crypto.JOSE.JWK | ||
8 | |||
9 | makeWrapped ''JWKSet | ||
diff --git a/overlays/spm/server/Crypto/Random/Instances.hs b/overlays/spm/server/Crypto/Random/Instances.hs new file mode 100644 index 00000000..6b0890be --- /dev/null +++ b/overlays/spm/server/Crypto/Random/Instances.hs | |||
@@ -0,0 +1,27 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | |||
3 | module Crypto.Random.Instances () where | ||
4 | |||
5 | import Prelude | ||
6 | import Crypto.Random | ||
7 | import System.Random | ||
8 | |||
9 | import qualified Data.ByteString as BS | ||
10 | |||
11 | import Data.Bits | ||
12 | |||
13 | |||
14 | instance RandomGen ChaChaDRG where | ||
15 | split = flip withDRG drgNew | ||
16 | |||
17 | genWord64 g = withRandomBytes g 8 $ \case | ||
18 | (map fromIntegral . BS.unpack -> [b1, b2, b3, b4, b5, b6, b7, b8]) | ||
19 | -> b1 `shiftL` 56 | ||
20 | .|. b2 `shiftL` 48 | ||
21 | .|. b3 `shiftL` 40 | ||
22 | .|. b4 `shiftL` 32 | ||
23 | .|. b5 `shiftL` 24 | ||
24 | .|. b6 `shiftL` 16 | ||
25 | .|. b7 `shiftL` 8 | ||
26 | .|. b8 | ||
27 | _other -> error "withRandomBytes did not return correct number of bytes" | ||
diff --git a/overlays/spm/server/Data/CaseInsensitive/Instances.hs b/overlays/spm/server/Data/CaseInsensitive/Instances.hs new file mode 100644 index 00000000..1f3f7a11 --- /dev/null +++ b/overlays/spm/server/Data/CaseInsensitive/Instances.hs | |||
@@ -0,0 +1,30 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | |||
4 | module Data.CaseInsensitive.Instances () where | ||
5 | |||
6 | import Prelude | ||
7 | import Database.Persist | ||
8 | import Database.Persist.Sql | ||
9 | |||
10 | import Data.CaseInsensitive (CI) | ||
11 | import qualified Data.CaseInsensitive as CI | ||
12 | |||
13 | import Data.Text (Text) | ||
14 | import qualified Data.Text as Text | ||
15 | import qualified Data.Text.Encoding as Text | ||
16 | |||
17 | import Control.Exception | ||
18 | |||
19 | |||
20 | instance PersistField (CI Text) where | ||
21 | toPersistValue = PersistLiteralEscaped . Text.encodeUtf8 . CI.original | ||
22 | fromPersistValue = \case | ||
23 | PersistText t -> Right $ CI.mk t | ||
24 | PersistLiteralEscaped bs -> case Text.decodeUtf8' bs of | ||
25 | Right t -> Right $ CI.mk t | ||
26 | Left err -> Left $ "Could not decode PersistLiteral as UTF-8: " <> Text.pack (displayException err) | ||
27 | o -> Left $ "Expected PersistText or PersistLiteral but got ‘" <> Text.pack (show o) <> "’" | ||
28 | |||
29 | instance PersistFieldSql (CI Text) where | ||
30 | sqlType _ = SqlOther "citext" | ||
diff --git a/overlays/spm/server/Data/UUID/Instances.hs b/overlays/spm/server/Data/UUID/Instances.hs new file mode 100644 index 00000000..b2268c96 --- /dev/null +++ b/overlays/spm/server/Data/UUID/Instances.hs | |||
@@ -0,0 +1,31 @@ | |||
1 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
2 | {-# LANGUAGE OverloadedStrings #-} | ||
3 | |||
4 | module Data.UUID.Instances () where | ||
5 | |||
6 | import Prelude | ||
7 | import Database.Persist | ||
8 | import Database.Persist.Sql | ||
9 | import Data.UUID (UUID) | ||
10 | import qualified Data.UUID as UUID | ||
11 | |||
12 | import qualified Data.ByteString.Char8 as CBS | ||
13 | import qualified Data.Text as Text | ||
14 | |||
15 | import Web.PathPieces | ||
16 | |||
17 | |||
18 | instance PersistField UUID where | ||
19 | toPersistValue = PersistLiteralEscaped . CBS.pack . UUID.toString | ||
20 | fromPersistValue (PersistLiteralEscaped uuidB8) = | ||
21 | case UUID.fromString $ CBS.unpack uuidB8 of | ||
22 | Just uuid -> Right uuid | ||
23 | Nothing -> Left "Invalid UUID" | ||
24 | fromPersistValue v = Left $ "Expected PersistLiteral but got ‘" <> Text.pack (show v) <> "’" | ||
25 | |||
26 | instance PersistFieldSql UUID where | ||
27 | sqlType _ = SqlOther "uuid" | ||
28 | |||
29 | instance PathPiece UUID where | ||
30 | toPathPiece = Text.pack . UUID.toString | ||
31 | fromPathPiece = UUID.fromString . Text.unpack | ||
diff --git a/overlays/spm/server/Spm/Server.hs b/overlays/spm/server/Spm/Server.hs new file mode 100644 index 00000000..1f785999 --- /dev/null +++ b/overlays/spm/server/Spm/Server.hs | |||
@@ -0,0 +1,271 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | module Spm.Server | ||
4 | ( main | ||
5 | ) where | ||
6 | |||
7 | import Prelude | ||
8 | import Spm.Api | ||
9 | import Servant | ||
10 | import Servant.Server.Experimental.Auth | ||
11 | |||
12 | import Network.Wai | ||
13 | import Network.Wai.Handler.Warp | ||
14 | import Network.Wai.Handler.Warp.Systemd | ||
15 | import Network.Wai.Middleware.RequestLogger | ||
16 | |||
17 | import Network.HTTP.Types | ||
18 | |||
19 | import Data.Text (Text) | ||
20 | import qualified Data.Text as Text | ||
21 | import qualified Data.Text.Encoding as Text | ||
22 | import Data.Attoparsec.Text | ||
23 | |||
24 | import qualified Data.ByteString.Lazy as LBS | ||
25 | |||
26 | import GHC.Generics (Generic) | ||
27 | import Type.Reflection (Typeable) | ||
28 | |||
29 | import Control.Applicative | ||
30 | import Control.Monad | ||
31 | import Control.Arrow | ||
32 | import Control.Monad.IO.Class | ||
33 | import Control.Monad.IO.Unlift | ||
34 | |||
35 | import Control.Lens hiding (Context) | ||
36 | |||
37 | import qualified Data.CaseInsensitive as CI | ||
38 | |||
39 | import System.IO | ||
40 | |||
41 | import Spm.Server.Database | ||
42 | |||
43 | import Database.Persist | ||
44 | import Database.Persist.Postgresql | ||
45 | import Data.Pool | ||
46 | |||
47 | import Control.Monad.Trans.Reader (ReaderT, runReaderT) | ||
48 | |||
49 | import Control.Monad.Logger | ||
50 | |||
51 | import Control.Monad.Morph | ||
52 | |||
53 | import System.Environment | ||
54 | |||
55 | import Control.Monad.Catch (Exception, MonadThrow(..)) | ||
56 | |||
57 | import qualified Data.UUID as UUID | ||
58 | import qualified Data.UUID.V4 as UUID | ||
59 | |||
60 | import qualified Data.Aeson as JSON | ||
61 | import Data.Aeson.Lens (_JSON) | ||
62 | |||
63 | import System.FilePath ((</>), isRelative) | ||
64 | |||
65 | import Crypto.JOSE.JWK hiding (Context) | ||
66 | import Crypto.JOSE.JWK.Instances () | ||
67 | |||
68 | import Crypto.Random.Instances () | ||
69 | import qualified Crypto.Random as Crypto | ||
70 | import Control.Monad.Trans.Random.Strict | ||
71 | import Control.Monad.Random.Class | ||
72 | |||
73 | import Data.Maybe | ||
74 | |||
75 | import Spm.Server.Wordlist | ||
76 | |||
77 | import qualified Data.Vector as Vector | ||
78 | |||
79 | import Data.Foldable | ||
80 | import Crypto.JWT hiding (Context) | ||
81 | import qualified Crypto.JWT as JWT | ||
82 | |||
83 | import Data.Time.Clock | ||
84 | |||
85 | import Control.Monad.Trans.Except | ||
86 | |||
87 | import Data.Monoid (First(..)) | ||
88 | |||
89 | import Numeric.Natural | ||
90 | |||
91 | import Spm.Server.Ctx | ||
92 | import Spm.Server.UI | ||
93 | |||
94 | |||
95 | hSslClientVerify, hSslClientSDn :: HeaderName | ||
96 | hSslClientVerify = "SSL-Client-Verify" | ||
97 | hSslClientSDn = "SSL-Client-S-DN" | ||
98 | |||
99 | |||
100 | data SSLClientVerify | ||
101 | = SSLClientVerifySuccess | ||
102 | | SSLClientVerifyOther Text | ||
103 | deriving (Eq, Ord, Read, Show, Generic, Typeable) | ||
104 | instance FromHttpApiData SSLClientVerify where | ||
105 | parseUrlPiece = (left Text.pack .) . parseOnly $ p <* endOfInput | ||
106 | where | ||
107 | p :: Parser SSLClientVerify | ||
108 | p = (SSLClientVerifySuccess <$ asciiCI "success") | ||
109 | <|> (SSLClientVerifyOther <$> takeText) | ||
110 | |||
111 | type instance AuthServerData (AuthProtect "spm_mailbox") = MailMailbox | ||
112 | |||
113 | type SpmServerApi = Header' '[Required, Strict] "SPM-Domain" MailDomain | ||
114 | :> AuthProtect "spm_mailbox" | ||
115 | :> SpmApi | ||
116 | :<|> "ui" :> Raw | ||
117 | |||
118 | spmServerApi :: Proxy SpmServerApi | ||
119 | spmServerApi = Proxy | ||
120 | |||
121 | |||
122 | requestMailMailbox :: Request -> Either Text MailMailbox | ||
123 | requestMailMailbox req = do | ||
124 | clientVerify <- getHeader hSslClientVerify | ||
125 | clientSDN <- getHeader hSslClientSDn | ||
126 | |||
127 | case clientVerify of | ||
128 | SSLClientVerifySuccess -> return () | ||
129 | o@(SSLClientVerifyOther _) -> Left $ "Expected “SSLClientVerifySuccess”, but got “" <> Text.pack (show o) <> "”" | ||
130 | spmMailbox <- left Text.pack $ parseOnly (asciiCI "CN=" *> (CI.mk <$> takeText) <* endOfInput) clientSDN | ||
131 | |||
132 | return $ _Wrapped # spmMailbox | ||
133 | where | ||
134 | getHeader :: forall a. FromHttpApiData a => HeaderName -> Either Text a | ||
135 | getHeader hdrName = parseHeader <=< maybeToEither ("Missing “" <> Text.decodeUtf8 (CI.original hdrName) <> "”") . lookup hdrName $ requestHeaders req | ||
136 | |||
137 | maybeToEither e = maybe (Left e) Right | ||
138 | |||
139 | mailboxAuthHandler :: AuthHandler Request MailMailbox | ||
140 | mailboxAuthHandler = mkAuthHandler handler | ||
141 | where | ||
142 | throw401 msg = throwError $ err401 { errBody = LBS.fromStrict $ Text.encodeUtf8 msg } | ||
143 | handler = either throw401 return . requestMailMailbox | ||
144 | |||
145 | mkSpmRequestLogger :: MonadIO m => m Middleware | ||
146 | mkSpmRequestLogger = liftIO $ mkRequestLogger loggerSettings | ||
147 | where | ||
148 | loggerSettings = defaultRequestLoggerSettings | ||
149 | { destination = Handle stderr | ||
150 | , outputFormat = ApacheWithSettings $ defaultApacheSettings | ||
151 | & setApacheUserGetter (preview (_Right . _Wrapped . to (Text.encodeUtf8. CI.original)) . requestMailMailbox) | ||
152 | & setApacheIPAddrSource FromFallback | ||
153 | } | ||
154 | |||
155 | type Handler' = ReaderT ServerCtx (LoggingT Handler) | ||
156 | type Server' api = ServerT api Handler' | ||
157 | |||
158 | data ServerCtxError | ||
159 | = ServerCtxNoInstanceId | ServerCtxInvalidInstanceId | ||
160 | | ServerCtxJwkSetCredentialFileNotRelative | ||
161 | | ServerCtxNoCredentialsDirectory | ||
162 | | ServerCtxJwkSetDecodeError String | ||
163 | | ServerCtxJwkSetEmpty | ||
164 | deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
165 | deriving anyclass (Exception) | ||
166 | |||
167 | mkSpmApp :: (MonadUnliftIO m, MonadThrow m) => m Application | ||
168 | mkSpmApp = do | ||
169 | requestLogger <- mkSpmRequestLogger | ||
170 | |||
171 | connStr <- liftIO $ maybe mempty (Text.encodeUtf8 . Text.pack) <$> lookupEnv "PGCONNSTR" | ||
172 | _sctxInstanceId <- maybe (throwM ServerCtxInvalidInstanceId) return . UUID.fromString =<< maybe (throwM ServerCtxNoInstanceId) return =<< liftIO (lookupEnv "SPM_INSTANCE") | ||
173 | jwksetCredentialFile <- liftIO $ fromMaybe "spm-keys.json" <$> lookupEnv "SPM_KEYS_CREDENTIAL" | ||
174 | unless (isRelative jwksetCredentialFile) $ throwM ServerCtxJwkSetCredentialFileNotRelative | ||
175 | credentialsDir <- maybe (throwM ServerCtxNoCredentialsDirectory) return =<< liftIO (lookupEnv "CREDENTIALS_DIRECTORY") | ||
176 | _sctxJwkSet@(JWKSet jwks) <- either (throwM . ServerCtxJwkSetDecodeError) return =<< liftIO (JSON.eitherDecodeFileStrict' $ credentialsDir </> jwksetCredentialFile) | ||
177 | when (null jwks) $ throwM ServerCtxJwkSetEmpty | ||
178 | |||
179 | runStderrLoggingT . withPostgresqlPool connStr 1 $ \_sctxSqlPool -> do | ||
180 | let | ||
181 | spmServerContext :: Context (AuthHandler Request MailMailbox ': '[]) | ||
182 | spmServerContext = mailboxAuthHandler :. EmptyContext | ||
183 | |||
184 | spmServer' = spmServer | ||
185 | :<|> Tagged uiServer | ||
186 | |||
187 | logger <- askLoggerIO | ||
188 | return $ serveWithContextT spmServerApi spmServerContext ((runReaderT ?? ServerCtx{..}) . hoist (runLoggingT ?? logger)) spmServer' | ||
189 | & requestLogger | ||
190 | |||
191 | spmSql :: ReaderT SqlBackend Handler' a -> Handler' a | ||
192 | spmSql act = do | ||
193 | sqlPool <- view sctxSqlPool | ||
194 | withResource sqlPool $ runReaderT act | ||
195 | |||
196 | spmJWT :: forall error a. Show error => ServerError -> ExceptT error IO a -> Handler' a | ||
197 | spmJWT errTemplate = either (\err -> throwError errTemplate{ errBody = LBS.fromStrict . Text.encodeUtf8 . Text.pack $ show err }) return <=< liftIO . runExceptT | ||
198 | |||
199 | generateLocal :: MonadIO m => SpmStyle -> m MailLocal | ||
200 | generateLocal SpmWords = fmap (review _Wrapped . CI.mk) . liftIO $ do | ||
201 | csprng <- Crypto.drgNew | ||
202 | fmap (Text.intercalate ".") . (evalRandT ?? csprng) $ | ||
203 | replicateM 2 $ (wordlist Vector.!) <$> getRandomR (0, pred $ Vector.length wordlist) | ||
204 | generateLocal SpmConsonants = fmap (review _Wrapped . CI.mk) . liftIO $ do | ||
205 | csprng <- Crypto.drgNew | ||
206 | fmap fold . (evalRandT ?? csprng) $ | ||
207 | replicateM 5 $ (consonants Vector.!) <$> getRandomR (0, pred $ Vector.length consonants) | ||
208 | |||
209 | spmServer :: MailDomain -> MailMailbox -> Server' SpmApi | ||
210 | spmServer dom mbox = whoami | ||
211 | :<|> jwkSet | ||
212 | :<|> instanceId | ||
213 | :<|> generate | ||
214 | :<|> claim | ||
215 | where | ||
216 | whoami = do | ||
217 | Entity _ Mailbox{mailboxIdent} <- maybe (throwError err404) return <=< spmSql . getBy $ UniqueMailbox mbox | ||
218 | return $ mailboxIdent ^. _Wrapped . re _Wrapped | ||
219 | |||
220 | jwkSet = views sctxJwkSet $ over _Wrapped (^.. folded . asPublicKey . _Just) | ||
221 | |||
222 | instanceId = view sctxInstanceId | ||
223 | |||
224 | generate (fromMaybe SpmWords -> style) = do | ||
225 | local <- spmSql $ | ||
226 | let | ||
227 | go :: Natural -> ReaderT SqlBackend Handler' MailLocal | ||
228 | go tries | ||
229 | | tries <= 0 = throwError err500{ errBody = "Could not find unused local part" } | ||
230 | | otherwise = do | ||
231 | local <- generateLocal style | ||
232 | doesExist <- exists | ||
233 | [ MailboxMappingDomain ==. dom | ||
234 | , MailboxMappingLocal ==. Just local | ||
235 | ] | ||
236 | if | doesExist -> go $ pred tries | ||
237 | | otherwise -> return local | ||
238 | in go 100 | ||
239 | t <- liftIO getCurrentTime | ||
240 | instanceId' <- view sctxInstanceId | ||
241 | jwks <- view $ sctxJwkSet . _Wrapped | ||
242 | tokenId <- liftIO UUID.nextRandom | ||
243 | let claimsSet = emptyClaimsSet | ||
244 | & claimIss ?~ (JWT.string # UUID.toText instanceId') | ||
245 | & claimAud ?~ Audience (pure $ dom ^. _Wrapped . to CI.original . re JWT.string) | ||
246 | & claimNbf ?~ NumericDate t | ||
247 | & claimIat ?~ NumericDate t | ||
248 | & claimExp ?~ NumericDate (600 `addUTCTime` t) | ||
249 | & claimJti ?~ UUID.toText tokenId | ||
250 | & unregisteredClaims . at "local" ?~ view (_Wrapped . re _JSON) local | ||
251 | spmJWT @JWT.Error err500 $ do | ||
252 | (jwsAlg, selectedJwk) <- withExceptT (fromMaybe JWT.NoUsableKeys . getFirst) . asum $ map (\jwk' -> (, jwk') <$> withExceptT (First . Just) (bestJWSAlg jwk')) jwks | ||
253 | signClaims selectedJwk (newJWSHeader ((), jwsAlg)) claimsSet | ||
254 | |||
255 | claim jwt = do | ||
256 | jwks <- view sctxJwkSet | ||
257 | let validationSettings' = defaultJWTValidationSettings ((== Just dom) . fmap (review _Wrapped . CI.mk) . preview JWT.string) | ||
258 | & jwtValidationSettingsAllowedSkew .~ 5 | ||
259 | claims <- spmJWT @JWT.JWTError err403 $ verifyClaims validationSettings' jwks jwt | ||
260 | mailboxMappingLocal <- maybe (throwError err400{ errBody = "Claim ‘local’ missing" }) (return . Just) $ claims ^? unregisteredClaims . ix "local" . _JSON . to CI.mk . re _Wrapped | ||
261 | |||
262 | spmSql $ do | ||
263 | Entity mailboxMappingMailbox _ <- maybe (throwError err404) return <=< getBy $ UniqueMailbox mbox | ||
264 | maybe (throwError err400{ errBody = "Address already claimed" }) (const $ return NoContent) =<< insertUnique MailboxMapping{mailboxMappingExtension = Nothing, mailboxMappingDomain = dom, ..} | ||
265 | |||
266 | main :: IO () | ||
267 | main = runSystemdWarp systemdSettings warpSettings =<< mkSpmApp | ||
268 | where | ||
269 | systemdSettings = defaultSystemdSettings | ||
270 | & requireSocketActivation .~ True | ||
271 | warpSettings = defaultSettings | ||
diff --git a/overlays/spm/server/Spm/Server/Ctx.hs b/overlays/spm/server/Spm/Server/Ctx.hs new file mode 100644 index 00000000..7b84e3d5 --- /dev/null +++ b/overlays/spm/server/Spm/Server/Ctx.hs | |||
@@ -0,0 +1,24 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | |||
3 | module Spm.Server.Ctx | ||
4 | ( ServerCtx(..) | ||
5 | , sctxSqlPool, sctxInstanceId, sctxJwkSet | ||
6 | ) where | ||
7 | |||
8 | import Data.UUID (UUID) | ||
9 | import Crypto.JOSE.JWK (JWKSet) | ||
10 | import Database.Persist.Postgresql | ||
11 | import Data.Pool | ||
12 | import Control.Lens.TH | ||
13 | |||
14 | import Type.Reflection (Typeable) | ||
15 | import GHC.Generics (Generic) | ||
16 | |||
17 | |||
18 | data ServerCtx = ServerCtx | ||
19 | { _sctxSqlPool :: Pool SqlBackend | ||
20 | , _sctxInstanceId :: UUID | ||
21 | , _sctxJwkSet :: JWKSet | ||
22 | } deriving (Generic, Typeable) | ||
23 | makeLenses ''ServerCtx | ||
24 | |||
diff --git a/overlays/spm/server/Spm/Server/Database.hs b/overlays/spm/server/Spm/Server/Database.hs new file mode 100644 index 00000000..cc133e06 --- /dev/null +++ b/overlays/spm/server/Spm/Server/Database.hs | |||
@@ -0,0 +1,73 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, UndecidableInstances #-} | ||
2 | |||
3 | module Spm.Server.Database | ||
4 | ( MailMailbox, MailLocal, MailExtension, MailDomain | ||
5 | , Mailbox(..), MailboxMapping(..) | ||
6 | , Key(..), EntityField(..), Unique(..) | ||
7 | ) where | ||
8 | |||
9 | import Prelude | ||
10 | |||
11 | import Database.Persist | ||
12 | import Database.Persist.Sql | ||
13 | import Database.Persist.TH | ||
14 | |||
15 | import GHC.Generics (Generic) | ||
16 | import Type.Reflection (Typeable) | ||
17 | |||
18 | import Data.Text (Text) | ||
19 | |||
20 | import Data.CaseInsensitive (CI) | ||
21 | import qualified Data.CaseInsensitive as CI | ||
22 | import Data.CaseInsensitive.Instances () | ||
23 | |||
24 | import Data.UUID (UUID) | ||
25 | import Data.UUID.Instances () | ||
26 | |||
27 | import Data.Int (Int64) | ||
28 | |||
29 | import Control.Lens | ||
30 | |||
31 | import Web.HttpApiData | ||
32 | |||
33 | |||
34 | newtype MailMailbox = MailMailbox | ||
35 | { unMailMailbox :: CI Text | ||
36 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
37 | deriving newtype (PersistField, PersistFieldSql) | ||
38 | makeWrapped ''MailMailbox | ||
39 | newtype MailLocal = MailLocal | ||
40 | { unMailLocal :: CI Text | ||
41 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
42 | deriving newtype (PersistField, PersistFieldSql) | ||
43 | makeWrapped ''MailLocal | ||
44 | newtype MailExtension = MailExtension | ||
45 | { unMailExtension :: CI Text | ||
46 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
47 | deriving newtype (PersistField, PersistFieldSql) | ||
48 | makeWrapped ''MailExtension | ||
49 | newtype MailDomain = MailDomain | ||
50 | { unMailDomain :: CI Text | ||
51 | } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) | ||
52 | deriving newtype (PersistField, PersistFieldSql) | ||
53 | makeWrapped ''MailDomain | ||
54 | |||
55 | instance FromHttpApiData MailDomain where | ||
56 | parseUrlPiece = fmap (review _Wrapped . CI.mk) . parseUrlPiece | ||
57 | |||
58 | |||
59 | share [mkPersist sqlSettings] [persistLowerCase| | ||
60 | Mailbox | ||
61 | Id UUID sqltype=uuid default=gen_random_uuid() | ||
62 | ident MailMailbox sql=mailbox | ||
63 | quota Int64 Maybe sql=quota_bytes MigrationOnly | ||
64 | UniqueMailbox ident | ||
65 | deriving Show | ||
66 | MailboxMapping | ||
67 | Id UUID sqltype=uuid default=gen_random_uuid() | ||
68 | local MailLocal Maybe | ||
69 | extension MailExtension Maybe | ||
70 | domain MailDomain | ||
71 | mailbox MailboxId | ||
72 | UniqueLocalDomain local domain sql=local_domain_unique !force | ||
73 | |] | ||
diff --git a/overlays/spm/server/Spm/Server/UI.hs b/overlays/spm/server/Spm/Server/UI.hs new file mode 100644 index 00000000..544e4f54 --- /dev/null +++ b/overlays/spm/server/Spm/Server/UI.hs | |||
@@ -0,0 +1,23 @@ | |||
1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} | ||
2 | |||
3 | module Spm.Server.UI | ||
4 | ( uiServer | ||
5 | ) where | ||
6 | |||
7 | import Prelude | ||
8 | |||
9 | import Network.Wai | ||
10 | |||
11 | import Network.Wai.Application.Static | ||
12 | import WaiAppStatic.Types | ||
13 | |||
14 | import Data.FileEmbed | ||
15 | |||
16 | |||
17 | uiServer :: Application | ||
18 | uiServer = staticApp settings | ||
19 | { ssLookupFile = \pcs -> ssLookupFile settings pcs >>= \case | ||
20 | LRNotFound -> ssLookupFile settings [unsafeToPiece "index.html"] | ||
21 | o -> return o | ||
22 | } | ||
23 | where settings = embeddedSettings $(embedDir "frontend") | ||
diff --git a/overlays/spm/server/Spm/Server/Wordlist.hs b/overlays/spm/server/Spm/Server/Wordlist.hs new file mode 100644 index 00000000..8109f07b --- /dev/null +++ b/overlays/spm/server/Spm/Server/Wordlist.hs | |||
@@ -0,0 +1,31 @@ | |||
1 | {-# LANGUAGE TemplateHaskell #-} | ||
2 | |||
3 | module Spm.Server.Wordlist | ||
4 | ( wordlist, consonants | ||
5 | ) where | ||
6 | |||
7 | import Prelude | ||
8 | import Language.Haskell.TH.Syntax | ||
9 | import Control.Monad.IO.Class | ||
10 | |||
11 | import Data.Text (Text) | ||
12 | import qualified Data.Text as Text | ||
13 | import qualified Data.Text.IO as Text | ||
14 | |||
15 | import Data.Vector (Vector) | ||
16 | import qualified Data.Vector as Vector | ||
17 | |||
18 | import Data.FileEmbed (makeRelativeToProject) | ||
19 | |||
20 | import Instances.TH.Lift () | ||
21 | |||
22 | |||
23 | {-# NOINLINE wordlist #-} | ||
24 | {-# NOINLINE consonants #-} | ||
25 | wordlist, consonants :: Vector Text | ||
26 | wordlist = $( do | ||
27 | fPath <- makeRelativeToProject "wordlist.txt" | ||
28 | addDependentFile fPath | ||
29 | lift . Vector.fromList =<< liftIO (filter (not . Text.null) . Text.words <$> Text.readFile fPath) | ||
30 | ) | ||
31 | consonants = Vector.fromList $ map Text.singleton "bcdfghjklmnpqrstvwxz" | ||