1  {-# LANGUAGE RecursiveDo #-}
  2  
  3  module Page.Settings (page) where
  4  
  5  import Common.Model
  6    ( Config (..),
  7      Owner (..),
  8      Repo (..),
  9      Token (..),
 10      darkMode,
 11      owner,
 12      repo,
 13      token,
 14    )
 15  import Control.Lens (to, (^.), (^?), _Just, _Wrapped)
 16  import Control.Monad (void, (<=<))
 17  import Control.Monad.Fix (MonadFix)
 18  import Control.Monad.IO.Class (MonadIO)
 19  import Data.Maybe (fromMaybe, isJust, isNothing)
 20  import Data.Text (Text)
 21  import qualified Data.Text as T
 22  import Reflex.Dom.Core hiding (Error)
 23  import Reflex.Extra (onClient)
 24  import qualified Request
 25  import Theme (getSystemDarkModeEvent, setDarkModeOn)
 26  import qualified Widget
 27  import qualified Widget.Icon as Icon
 28  import Witherable (catMaybes)
 29  import Prelude hiding (unzip)
 30  
 31  page ::
 32    ( DomBuilder t m,
 33      Prerender t m,
 34      MonadHold t m,
 35      PostBuild t m,
 36      MonadFix m,
 37      PerformEvent t m,
 38      TriggerEvent t m,
 39      MonadIO (Performable m)
 40    ) =>
 41    Maybe Config ->
 42    m (Event t Config)
 43  page mbConfig =
 44    Widget.card $ do
 45      rec dyOwner <- fmap MkOwner <$> inputOwner evOwnerValid
 46          dyRepo <- fmap MkRepo <$> inputRepo (updated dyRepoExists)
 47          dyToken <- fmap mkToken <$> inputToken (updated dyTokenValid)
 48          dyDarkMode <- inputDarkMode
 49  
 50          void . setDarkModeOn $ updated dyDarkMode
 51  
 52          -- The owner request
 53          let evUserRequest = updated $ Request.users <$> dyToken <*> dyOwner
 54          evOwnerResponse <- debounceAndRequest evUserRequest
 55          -- 401 means the token is wrong. In this case we assume the owner
 56          -- exists. Because the token is wrong, the form cannot be submitted
 57          -- anyway.
 58          let evOwnerValid =
 59                leftmost
 60                  [ -- The owner is valid
 61                    is200Or401 <$> evOwnerResponse,
 62                    -- It is currently edited
 63                    False <$ updated dyOwner
 64                  ]
 65  
 66          -- The repo request
 67          let evContentRequest =
 68                updated $
 69                  Request.contents
 70                    <$> dyToken <*> dyOwner <*> dyRepo <*> pure mempty
 71          evRepoResponse <- debounceAndRequest evContentRequest
 72          -- Same remark for 401
 73          dyRepoExists <-
 74            holdDyn (isJust mbRepo) $
 75              leftmost
 76                [ is200Or401 <$> evRepoResponse,
 77                  False <$ updated dyOwner,
 78                  False <$ updated dyRepo
 79                ]
 80  
 81          -- The token request
 82          -- The token is valid:
 83          -- - if empty
 84          -- - if the rate limit endpoint returns 200
 85          let evToken = updated dyToken
 86              evMaybeTokenRequest = fmap Request.rateLimit <$> evToken
 87          evTokenResponse <-
 88            -- dont debounce the request if the token is empty
 89            fmap (gate (isJust <$> current dyToken))
 90              . debounceAndRequest
 91              $ catMaybes evMaybeTokenRequest
 92          let evTokenValidOrEmpty =
 93                leftmost
 94                  [ -- Valid non empty token
 95                    is200 <$> evTokenResponse,
 96                    -- Empty token
 97                    isNothing <$> evToken,
 98                    -- Token currently edited
 99                    False <$ evToken
100                  ]
101          -- In the initial state, the token is either empty either loaded
102          -- from the local storage. In both cases, we assume it is valid.
103          dyTokenValid <- holdDyn True evTokenValidOrEmpty
104  
105      let dyCanSave = (&&) <$> dyRepoExists <*> dyTokenValid
106      evSave <- saveButton dyCanSave
107  
108      let beConfig =
109            current $
110              MkConfig <$> dyOwner
111                <*> dyRepo
112                <*> dyToken
113                <*> dyDarkMode
114      pure $ tag beConfig evSave
115    where
116      inputOwner evValid =
117        inputWidget
118          MkText
119          "Owner"
120          True
121          "name"
122          (fromMaybe "" mbOwner)
123          (isJust mbOwner)
124          evValid
125          Nothing
126      inputRepo evValid =
127        inputWidget
128          MkText
129          "Repository"
130          True
131          "repository"
132          (fromMaybe "" mbRepo)
133          (isJust mbRepo)
134          evValid
135          Nothing
136      inputToken evValid =
137        inputWidget
138          MkPassword
139          "Token"
140          False
141          "github_xxx"
142          (fromMaybe "" mbToken)
143          True
144          evValid
145          (Just "Needed to access private repositories")
146  
147      inputDarkMode = do
148        evSystemDarkMode <- getSystemDarkModeEvent
149        let darkModeFromConfig = fromMaybe False mbDarkMode
150            evSystemDarkModeWhenNotSet
151              -- Dont default with the system when we have a value in the config
152              | isJust mbDarkMode = never
153              | otherwise = evSystemDarkMode
154        elClass "div" "form-control" $
155          elClass "label" "label cursor-pointer" $ do
156            elClass "span" "label-text" $
157              text "Dark mode"
158            _inputElement_checked
159              <$> inputElement
160                ( def
161                    & inputElementConfig_initialChecked .~ darkModeFromConfig
162                    & inputElementConfig_setChecked .~ evSystemDarkModeWhenNotSet
163                    & initialAttributes
164                      .~ ("class" =: "toggle" <> "type" =: "checkbox")
165                )
166  
167      saveButton dyEnable = do
168        (ev, _) <-
169          elDynAttr'
170            "button"
171            (constDyn ("class" =: buttonClasses) <> (enableAttr <$> dyEnable))
172            $ text "Save"
173        pure $ domEvent Click ev
174  
175      mbOwner = mbConfig ^? _Just . owner . _Wrapped
176      mbRepo = mbConfig ^? _Just . repo . _Wrapped
177      mbToken = mbConfig ^? _Just . token . _Just . _Wrapped
178      mbDarkMode = mbConfig ^? _Just . darkMode
179  
180      mkToken "" = Nothing
181      mkToken txToken = Just $ MkToken txToken
182  
183      debounceAndRequest = onClient . performRequestAsyncWithError <=< debounce 0.5
184  
185      is200 = checkStatus (== 200)
186      is200Or401 = checkStatus (`elem` [200, 401])
187  
188      checkStatus _ (Left _) = False
189      checkStatus p (Right response) = response ^. xhrResponse_status . to p
190  
191      enableAttr True = mempty
192      enableAttr False = "disabled" =: "true"
193  
194  data InputType = MkPassword | MkText
195  
196  toText :: InputType -> Text
197  toText MkPassword = "password"
198  toText MkText = "text"
199  
200  inputWidget ::
201    (DomBuilder t m, MonadHold t m, MonadFix m, PostBuild t m) =>
202    InputType ->
203    Text ->
204    Bool ->
205    Text ->
206    Text ->
207    Bool ->
208    Event t Bool ->
209    Maybe Text ->
210    m (Dynamic t Text)
211  inputWidget inputType label mandatory placeholder initialValue valid evValid mbHelp =
212    elClass "div" "form-control w-full" $ do
213      elAttr "label" ("class" =: "label" <> "for" =: inputId) $
214        elClass "span" "label-text" $
215          text inputLabel
216  
217      dyInput <- elClass "div" "relative" $ do
218        rec dyInput <-
219              value
220                <$> inputElement
221                  ( def
222                      & inputElementConfig_initialValue .~ initialValue
223                      & initialAttributes
224                        .~ ( "class" =: inputClasses' valid
225                               <> "type" =: toText inputType
226                               <> "placeholder" =: placeholder
227                               <> "id" =: inputId
228                           )
229                      & modifyAttributes
230                        .~ ( ((=:) "class" . Just . inputClasses' <$> evValid)
231                               <> (toggleInputType inputType <$> evPasswordVisible)
232                           )
233                  )
234            evPasswordVisible <- elEye inputType
235        pure dyInput
236  
237      elHelp mbHelp
238  
239      pure dyInput
240    where
241      inputClasses' = inputClasses inputType
242  
243      inputId = T.toLower label
244      inputLabel = label <> if mandatory then " *" else ""
245  
246      toggleInputType MkText _ = mempty
247      toggleInputType MkPassword True = "type" =: Just "text"
248      toggleInputType MkPassword False = "type" =: Just "password"
249  
250      elEye MkText = pure never
251      elEye MkPassword = do
252        rec ev <- elClass
253              "div"
254              "absolute inset-y-0 right-0 pr-3 flex items-center"
255              $ do
256                (e, _) <-
257                  elDynClass'
258                    "span"
259                    (eyeClasses <$> dyPasswordVisible)
260                    blank
261                pure $ domEvent Click e
262            dyPasswordVisible <- toggle False ev
263        pure $ updated dyPasswordVisible
264  
265      eyeClasses = T.unwords . ([Icon.solid, "cursor-pointer"] <>) . pure . eyeIcon
266  
267      eyeIcon True = Icon.eyeSlashName
268      eyeIcon False = Icon.eyeName
269  
270      elHelp Nothing = pure ()
271      elHelp (Just help) =
272        elClass "label" "label" $
273          elClass "span" "label-text-alt" $
274            text help
275  
276  inputClasses :: InputType -> Bool -> Text
277  inputClasses inputType valid =
278    T.unwords $
279      ["input", "input-bordered", "w-full"]
280        <> validClasses valid
281        <> inputTypeClasses inputType
282    where
283      validClasses True = mempty
284      validClasses False = ["input-error"]
285      -- Make room for the eye icon
286      inputTypeClasses MkPassword = ["pr-10"]
287      inputTypeClasses MkText = mempty
288  
289  buttonClasses :: Text
290  buttonClasses = T.unwords ["w-full", "btn", "btn-primary"]