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
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
{-# Language RecordWildCards #-}
{-# Language ApplicativeDo #-}
module Fig.Web.Utils
( FigWebException(..)
, loadConfig
, Config(..)
, resetUserPassword
, module Network.HTTP.Types.Status
, onGet, onPost, onPut, onDelete
, status
, body, bodyJSON
, queryParam, queryParamMaybe, formParam, formParamMaybe, pathParam
, header, addHeader
, respondBytes, respondText, respondJSON, respondHTMLText, respondHTML, redirect
, WebsocketHandler
, websocket
, BusEventHandler, BusEventHandlers
, busEvents
, handleBusEvent
, subscribeBusEvents
, module Lucid.Html5
) where
import Fig.Prelude
import System.Exit (ExitCode(..))
import qualified System.Process as Proc
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import qualified Data.Text as Text
import qualified Data.Text.Lazy as Text.L
import qualified Data.ByteString.Lazy as BS.L
import qualified Data.Aeson as Aeson
import qualified Data.Map.Strict as Map
import Network.HTTP.Types.Status
import qualified Network.Wai.Handler.WebSockets as Wai.WS
import qualified Network.WebSockets as WS
import qualified Web.Scotty as Sc
import qualified Lucid as L
import Lucid.Html5
import qualified Toml
import Fig.Bus.Binary.Client
newtype FigWebException = FigWebException Text
deriving (Show, Eq, Ord)
instance Exception FigWebException
data Config = Config
{ port :: !Int
, assetPath :: !FilePath
, dataPath :: !FilePath
, clientId :: !Text
, authToken :: !Text
, dbHost :: !Text
, lldapCli :: !FilePath
, lldapHost :: !Text
, lldapUser :: !Text
, lldapPassword :: !Text
} deriving (Show, Eq, Ord)
configCodec :: Toml.TomlCodec Config
configCodec = do
port <- Toml.int "port" Toml..= (\a -> a.port)
assetPath <- Toml.string "asset_path" Toml..= (\a -> a.assetPath)
dataPath <- Toml.string "data_path" Toml..= (\a -> a.dataPath)
clientId <- Toml.text "client_id" Toml..= (\a -> a.clientId)
authToken <- Toml.text "auth_token" Toml..= (\a -> a.authToken)
dbHost <- Toml.text "db_host" Toml..= (\a -> a.dbHost)
lldapCli <- Toml.string "lldap_cli" Toml..= (\a -> a.lldapCli)
lldapHost <- Toml.text "lldap_host" Toml..= (\a -> a.lldapHost)
lldapUser <- Toml.text "lldap_user" Toml..= (\a -> a.lldapUser)
lldapPassword <- Toml.text "lldap_password" Toml..= (\a -> a.lldapPassword)
pure $ Config{..}
loadConfig :: FilePath -> IO Config
loadConfig path = Toml.decodeFileEither configCodec path >>= \case
Left err -> throwM . FigWebException $ tshow err
Right config -> pure config
-- | Reset the password in LDAP for the specified user (creating the user if necessary)
resetUserPassword :: MonadIO m => Config -> Text -> Text -> m (Maybe Text)
resetUserPassword cfg user uid = do
let login = Text.toLower user
password <- UUID.toText <$> liftIO UUID.nextRandom
(exitCode, out0, err0) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
. Proc.proc cfg.lldapCli $ unpack <$>
[ "-H", cfg.lldapHost
, "-D", cfg.lldapUser
, "-w", cfg.lldapPassword
, "user", "add", login, uid <> "@users.colonq.computer"
, "-p", password
, "-f", uid
]
(_, out1, err1) <- liftIO . flip Proc.readCreateProcessWithExitCode ""
. Proc.proc cfg.lldapCli $ unpack <$>
[ "-H", cfg.lldapHost
, "-D", cfg.lldapUser
, "-w", cfg.lldapPassword
, "user", "group", "add", login, "fig_users"
]
case exitCode of
ExitSuccess -> pure $ Just password
ExitFailure _ -> do
log . pack $ mconcat
[ "LDAP CLI error:\n"
, out0, err0
, out1, err1
]
pure Nothing
onGet :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
onGet = Sc.get
onPost :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
onPost = Sc.post
onPut :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
onPut = Sc.put
onDelete :: Sc.RoutePattern -> Sc.ActionM () -> Sc.ScottyM ()
onDelete = Sc.delete
status :: Status -> Sc.ActionM ()
status = Sc.status
body :: Sc.ActionM ByteString
body = BS.L.toStrict <$> Sc.body
bodyJSON :: Aeson.FromJSON a => Sc.ActionM a
bodyJSON = Sc.jsonData
queryParam :: Sc.Parsable a => Text -> Sc.ActionM a
queryParam = Sc.queryParam . Text.L.fromStrict
queryParamMaybe :: Sc.Parsable a => Text -> Sc.ActionM (Maybe a)
queryParamMaybe = Sc.queryParamMaybe . Text.L.fromStrict
formParam :: Sc.Parsable a => Text -> Sc.ActionM a
formParam = Sc.formParam . Text.L.fromStrict
formParamMaybe :: Sc.Parsable a => Text -> Sc.ActionM (Maybe a)
formParamMaybe = Sc.formParamMaybe . Text.L.fromStrict
pathParam :: Sc.Parsable a => Text -> Sc.ActionM a
pathParam = Sc.pathParam . Text.L.fromStrict
header :: Text -> Sc.ActionM (Maybe Text)
header h = Sc.header (Text.L.fromStrict h) >>= \case
Nothing -> pure Nothing
Just t -> pure . Just $ Text.L.toStrict t
addHeader :: Text -> Text -> Sc.ActionM ()
addHeader h v = Sc.addHeader (Text.L.fromStrict h) (Text.L.fromStrict v)
respondBytes :: ByteString -> Sc.ActionM ()
respondBytes = Sc.raw . BS.L.fromStrict
respondText :: Text -> Sc.ActionM ()
respondText = Sc.text . Text.L.fromStrict
respondJSON :: Aeson.ToJSON a => a -> Sc.ActionM ()
respondJSON = Sc.json
respondHTMLText :: Text -> Sc.ActionM ()
respondHTMLText = Sc.html . Text.L.fromStrict
respondHTML :: L.Html () -> Sc.ActionM ()
respondHTML = Sc.html . L.renderText . html_
redirect :: Text -> Sc.ActionM ()
redirect = Sc.redirect . Text.L.fromStrict
type WebsocketHandler = (ByteString, WS.Connection -> IO ())
websocket :: [WebsocketHandler] -> Sc.ScottyM ()
websocket hs = Sc.middleware $ Wai.WS.websocketsOr WS.defaultConnectionOptions handler
where
handler pending = case lookup (WS.requestPath (WS.pendingRequest pending)) hs of
Nothing -> WS.rejectRequest pending ""
Just h -> WS.acceptRequest pending >>= \c -> WS.withPingThread c 30 (pure ()) $ h c
type BusEventHandler = (ByteString, ByteString -> IO ())
type BusEventHandlers = Map.Map ByteString (ByteString -> IO ())
busEvents :: [BusEventHandler] -> BusEventHandlers
busEvents = Map.fromList
handleBusEvent :: BusEventHandlers -> ByteString -> ByteString -> IO ()
handleBusEvent hs ev d = case Map.lookup ev hs of
Just h -> h d
Nothing -> log $ "Invalid event: " <> tshow ev
subscribeBusEvents :: Commands IO -> BusEventHandlers -> IO ()
subscribeBusEvents cmds hs = forM_ (Map.keys hs) $ \ev -> do
cmds.subscribe ev
|
