Account creation in LDAP using Twitch

4 files changed, 65 insertions, 7 deletions

diff --git a/fig-web/src/Fig/Web.hs b/fig-web/src/Fig/Web.hs
index 5065378..5d32f75 100644
--- a/fig-web/src/Fig/Web.hs
+++ b/fig-web/src/Fig/Web.hs
@@ -18,7 +18,7 @@ import qualified Data.ByteString.Base64 as BS.Base64
 import qualified Data.Set as Set
 
 import qualified Network.Wai as Wai
--- import qualified Network.Wai.Middleware.Static as Wai.Static
+import qualified Network.Wai.Middleware.Static as Wai.Static
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Network.WebSockets as WS
 
@@ -30,6 +30,7 @@ import Fig.Web.Utils
 import Fig.Web.Auth
 import Fig.Web.State
 import qualified Fig.Web.DB as DB
+import qualified Fig.Web.LDAP as LDAP
 
 data LiveEvent
   = LiveEventOnline !(Set.Set Text)
@@ -51,14 +52,14 @@ server cfg busAddr = do
         case d of
           SExprList (ev:rest)
             | ev == [sexp|(monitor twitch stream online)|] -> do
-                let live = mapMaybe (\case SExprString s -> Just s; _ -> Nothing) rest
+                let live = mapMaybe (\case SExprString s -> Just s; _other -> Nothing) rest
                 let new = Set.fromList live 
                 old <- MVar.swapMVar currentlyLive new
                 let online = Set.difference new old
                 let offline = Set.difference old new
                 unless (Set.null online) . Chan.writeChan liveEvents $ LiveEventOnline online
                 unless (Set.null offline) . Chan.writeChan liveEvents $ LiveEventOnline offline
-          _ -> log $ "Invalid event: " <> tshow d
+          _other -> log $ "Invalid event: " <> tshow d
     )
     (pure ())
 
@@ -72,8 +73,9 @@ app cfg cmds liveEvents currentlyLive = do
   log "Connected! Server active."
   st <- stateRef
   Sc.scottyApp do
-    -- Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
-    Sc.get "/" $ Sc.redirect "/index.html"
+    Sc.middleware $ Wai.Static.staticPolicy $ Wai.Static.addBase cfg.assetPath
+    Sc.get "/register" do
+      Sc.redirect "/register.html"
     Sc.get "/unauthorized" do
       Sc.status status401
       Sc.text $ mconcat
@@ -90,6 +92,14 @@ app cfg cmds liveEvents currentlyLive = do
         , "for example:\n"
         , "  curl https://secure.colonq.computer --cookie cookies.txt\n"
         ]
+    Sc.get "/api/register" $ authed cfg \auth -> do
+      let user = Text.toLower auth.name
+      LDAP.resetUserPassword cfg user auth.id >>= \case
+        Nothing -> do
+          Sc.status status500
+          Sc.text "failed to register"
+        Just pass -> do
+          Sc.text . Text.L.fromStrict $ user <> " " <> pass
     Sc.get "/api/check" $ authed cfg \auth -> do
       Sc.json @[Text] [auth.id, auth.name]
     Sc.put "/api/buffer" do
diff --git a/fig-web/src/Fig/Web/Auth.hs b/fig-web/src/Fig/Web/Auth.hs
index 3076d1f..2fb23b9 100644
--- a/fig-web/src/Fig/Web/Auth.hs
+++ b/fig-web/src/Fig/Web/Auth.hs
@@ -15,7 +15,6 @@ import qualified Jose.Jwk as Jwk
 import qualified Jose.Jwt as Jwt
 
 import qualified Web.Scotty as Sc
-import qualified Web.Scotty.Cookie as Sc.C
 
 import Fig.Web.Utils
 
@@ -65,7 +64,7 @@ checkAuth cfg =
       let pairs = Map.fromList $ flip mapMaybe authstr \s ->
             case Text.splitOn "=" s of
               [k, v] -> Just (k, Text.takeWhile (/='"') $ Text.drop 1 v)
-              _ -> Nothing
+              _other -> Nothing
       case (Map.lookup "token" pairs, Map.lookup "nonce" pairs) of
         (Just token, Just nonce) -> do
           log $ tshow token
diff --git a/fig-web/src/Fig/Web/LDAP.hs b/fig-web/src/Fig/Web/LDAP.hs
new file mode 100644
index 0000000..e9861a9
--- /dev/null
+++ b/fig-web/src/Fig/Web/LDAP.hs
@@ -0,0 +1,39 @@
+module Fig.Web.LDAP 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 Fig.Web.Utils
+
+-- | 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 <- liftIO $ Proc.withCreateProcess
+    (Proc.proc cfg.lldapCli $ unpack <$>
+     [ "-H", cfg.lldapHost
+     , "-D", cfg.lldapUser
+     , "-w", cfg.lldapPassword
+     , "user", "add", login, login <> "@users.colonq.computer"
+     , "-p", password
+     , "-f", uid
+     ])
+    \_ _ _ h -> Proc.waitForProcess h
+  liftIO $ Proc.withCreateProcess
+    (Proc.proc cfg.lldapCli $ unpack <$>
+     [ "-H", cfg.lldapHost
+     , "-D", cfg.lldapUser
+     , "-w", cfg.lldapPassword
+     , "user", "group", "add", login, "fig_users"
+     ])
+    \_ _ _ h -> void $ Proc.waitForProcess h
+  case exitCode of
+    ExitSuccess -> pure $ Just password
+    ExitFailure _ -> pure Nothing
diff --git a/fig-web/src/Fig/Web/Utils.hs b/fig-web/src/Fig/Web/Utils.hs
index b6c385a..004ba5a 100644
--- a/fig-web/src/Fig/Web/Utils.hs
+++ b/fig-web/src/Fig/Web/Utils.hs
@@ -25,17 +25,27 @@ instance Exception FigWebException
 
 data Config = Config
   { port :: !Int
+  , assetPath :: !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)
   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