<commit_before>{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExplicitForAll, NoImplicitPrelude, NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings, RecursiveDo, ScopedTypeVariables          #-}
{-# LANGUAGE TypeApplications, DataKinds                                  #-}


{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}

module Main where

import Servant.API
import ClassyPrelude
import Reflex
import Reflex.Dom
import Servant.Reflex
import Lens.Micro ((^.), to)
import qualified Language.Javascript.JSaddle.Warp as JSWarp (run)

import Data.Proxy
import Data.Functor.Misc
import Data.Functor.Const

import Shaped
import qualified Generics.SOP as SOP
import Generics.SOP ((:.:)(..), type (-.->)(..), hzipWith, Code, unComp)

import MockAPI

main :: IO ()
main = do
  -- putStrLn "Server listening on port 8081"
  -- JSWarp.run 8081 $ mainWidget $ void $ textForm mailInputConfig mockValUser
  JSWarp.run 8081 $ mainWidget $ body
  -- JSWarp.run 8081 $ mainWidget $ do
  --   void $ form userWidget clientValidation

body :: forall t m. MonadWidget t m => m ()
body = do
  -- Instructions to use the server at localhost and to invoke the api
  -- Note the usage of ScopedTypeVariables to be able to talk about the monad we're referring to
  let url = BaseFullUrl Http "localhost" 8081 ""
      (invokeAPI :<|> _ :<|> _) = client (Proxy @MockApi) (Proxy @m) (constDyn url)
  -- A description of the visual elements
  divClass "login-clean" $ do
    el "form" $ mdo
      hiddenTitle
      icon
      user <- form userWidget clientValidation formErrorFromServer
      send <- buttonElement send responseEvent
      forgotYourUsername
      serverResponse <- let query = either (const $ Left "Please fill correctly the fields above") Right <$> user
                        in (fmap . fmap) parseReqResult (invokeAPI query send)
      let authFromServer      = snd . fanEither . snd . fanEither $ serverResponse
          formErrorFromServer = fst . fanEither . snd . fanEither $ serverResponse
          responseEvent = () <$ serverResponse
      -- A visual feedback for errors:
      a <- holdDyn "" $ either id (const "") <$> serverResponse
      el "h2" (dynText a)
      -- A visual feedback on authentication:
      authOkFeedback <- holdDyn "" ("Authenticated" <$ authFromServer)
      el "h2" (dynText authOkFeedback)
  return ()

--------------------------------------------------------------------------------
-- Implementation of the visual elements:

hiddenTitle, icon :: DomBuilder t m => m ()
hiddenTitle = elClass "h2" "sr-only" (text "Login Form")
icon = divClass "illustration" (elClass "i" "icon ion-ios-navigate" $ pure ())

mailInputConfig :: Reflex t => TextInputConfig t
mailInputConfig =
  def & textInputConfig_attributes .~ constDyn
        ("class" =: "form-control" <> "name" =: "email" <> "placeholder" =: "Email")
      & textInputConfig_inputType .~ "email"

passInputConfig :: Reflex t => TextInputConfig t
passInputConfig =
  def & textInputConfig_attributes .~ constDyn
        ("class" =: "form-control" <> "name" =: "password" <> "placeholder" =: "Password")
      & textInputConfig_inputType .~ "password"

buttonElement :: DomBuilder t m => Event t () -> Event t () -> m (Event t ())
buttonElement disable enable = divClass "form-group" $ do
  (e, _) <- element "button" conf (text "Log in")
  return (domEvent Click e)
  where
    conf = def & elementConfig_initialAttributes .~ initialAttr
               & elementConfig_modifyAttributes  .~ mergeWith (\_ b -> b)
                   [ const disableAttr <$> disable
                   , const enableAttr <$> enable ]
    initialAttr = "class" =: "btn btn-primary btn-block" <> "type" =: "button"
    disableAttr = fmap Just initialAttr  <> "disabled" =: Just "true"
    enableAttr  = fmap Just initialAttr  <> "disabled" =: Nothing

forgotYourUsername :: DomBuilder t m => m ()
forgotYourUsername = elAttr "a"
  ("href" =: "#" <> "class" =: "forgotYourUsername")
  (text "Forgot your email or password?")

userWidget :: (MonadWidget t m) => UserShaped (FormletSimple t m)
userWidget = UserShaped
  (FormletSimple $ userWidgetInternal mailInputConfig)
  (FormletSimple $ userWidgetInternal passInputConfig)

-- Forms for the shaped approach: This should be supplied by the user, as it's a
-- rendering of the particular markup the user wants for the form.
userWidgetInternal :: MonadWidget t m => TextInputConfig t -> Dynamic t (Maybe Text) -> m (Dynamic t Text)
userWidgetInternal conf err = do
  textBox   <- textInput conf
  firstBlur <- headE $ select (textBox ^. textInput_builderElement
                                        . to _inputElement_element
                                        . to _element_events)
                              (WrapArg Blur)
  displayedErr <- join <$> holdDyn (constDyn Nothing) (err <$ firstBlur)
  el "error" $ dynText (maybe "" id <$> displayedErr)
  return (value textBox)


--------------------------------------------------------------------------------
-- Things to be moved out of here
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- Parse the response from the API. This function could be in servant-reflex
-- (not in reflex-dom). In the meantime we'll keep it in shaped.
parseReqResult :: ReqResult a -> Either Text a
parseReqResult (ResponseSuccess a _) = Right a
parseReqResult (ResponseFailure t _) = Left t
parseReqResult (RequestFailure s)    = Left s

---------------------------------------------------------------------------------

-- This function is completely generic, should be moved in
-- Shaped.Validation.Reflex, or something
form :: MonadWidget t m
     => UserShaped (FormletSimple t m)            -- ^ a description of the widgets
     -> UserShaped (Validation (Either Text))     -- ^ the clientside validation
     -> Event t (UserShaped (Const (Maybe Text))) -- ^ Error from the server
     -> m (Dynamic t (Either (UserShaped (Const (Maybe Text))) User))
form shapedWidget shapedValidation errServer = mdo
  tentative <- createInterface (splitShaped errorEvent) shapedWidget
  let validationResult = transfGen . flip validateRecord shapedValidation <$> tentative
      errorEvent = leftmost [ updated $ either id (const nullError) <$> validationResult
                            , errServer ]
  return validationResult

type Endpoint t m = Dynamic t (Either Text User)
                 -> Event t ()
                 -> m (Event t (ReqResult (Either (UserShaped (Const (Maybe Text))) User)))

-- formAllIncluded :: MonadWidget t m
--      => UserShaped (FormletSimple t m)            -- ^ a description of the widgets
--      -> UserShaped (Validation (Either Text))     -- ^ the clientside validation
--      -> Event t (UserShaped (Const (Maybe Text))) -- ^ Error from the server, to eliminate
--      -> 
--      -> m (Dynamic t (Either (UserShaped (Const (Maybe Text))) User))
-- formAllIncluded shapedWidget shapedValidation errServer = mdo
--   tentative <- createInterface (splitShaped errorEvent) shapedWidget
--   let validationResult = transfGen . flip validateRecord shapedValidation <$> tentative
--       errorEvent = leftmost [ updated $ either id (const nullError) <$> validationResult
--                             , errServer ]
--   return validationResult

-- We have to transform a:
-- eResult :: Event t (UserShaped (Const (Maybe Text)))
-- into a
-- nullError' :: UserShaped (Event t :.: Const (Maybe Text))
-- to feed it back recursively to the form.
-- This function seems completely general to me, so should be generalized and taken away
-- TODO: Generalize
-- TODO: Move
splitShaped :: Reflex t => Event t (UserShaped (Const (Maybe Text))) -> UserShaped (Event t :.: Const (Maybe Text))
splitShaped ev = UserShaped<commit_msg>New version with compact main<commit_after>{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExplicitForAll, NoImplicitPrelude, NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings, RecursiveDo, ScopedTypeVariables          #-}
{-# LANGUAGE TypeApplications, DataKinds                                  #-}


{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fdefer-typed-holes #-}

module Main where

import Servant.API
import ClassyPrelude
import Reflex
import Reflex.Dom
import Servant.Reflex
import Lens.Micro ((^.), to)
import qualified Language.Javascript.JSaddle.Warp as JSWarp (run)

import Data.Proxy
import Data.Functor.Misc
import Data.Functor.Const

import Shaped
import qualified Generics.SOP as SOP
import Generics.SOP ((:.:)(..), type (-.->)(..), hzipWith, Code, unComp)

import MockAPI

main :: IO ()
main = do
  -- putStrLn "Server listening on port 8081"
  -- JSWarp.run 8081 $ mainWidget $ void $ textForm mailInputConfig mockValUser
  JSWarp.run 8081 $ mainWidget $ body
  -- JSWarp.run 8081 $ mainWidget $ do
  --   void $ form userWidget clientValidation

body :: forall t m. MonadWidget t m => m ()
body = do
  -- Instructions to use the server at localhost and to invoke the api
  -- Note the usage of ScopedTypeVariables to be able to talk about the monad we're referring to
  let url = BaseFullUrl Http "localhost" 8081 ""
      (invokeAPI :<|> _ :<|> _) = client (Proxy @MockApi) (Proxy @m) (constDyn url)
  -- A description of the visual elements
  void . divClass "login-clean" . el "form" $ do
    hiddenTitle
    icon
    (_, serverResponse) <- formNEW userWidget clientValidation invokeAPI
    forgotYourUsername
    el "h3" (dynText =<< feedback serverResponse)
  return ()

feedback :: MonadWidget t m
         => Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User))
         -> m (Dynamic t Text)
feedback e = holdDyn "" . ffor e $
  either id
         (either (const "Please fill correctly the informations above")
                 (const "Authenticated"))


-- serverCommError :: MonadWidget t m
--                 => Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User))
--                 -> m (Dynamic t (Maybe Text))
-- serverCommError e = holdDyn Nothing $ either Just (const Nothing) <$> e

-- serverAuth :: Reflex t
--            => Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User))
--            -> Event t User
-- serverAuth = snd . fanEither . snd . fanEither

-- serverAuth' :: Reflex t
--             => Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User))
--             -> m (Dynamic t (Maybe User))
-- serverAuth' = snd . fanEither . snd . fanEither

-- serverFormError :: MonadWidget t m
--                 => Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User))
--                 -> m (UserShaped (Const (Maybe Text)))
-- serverFormError e = holdDyn Nothing $ either Just (const Nothing) <$> e

-- displayMaybe :: MonadWidget t m => Dynamic t (Maybe a) -> (a -> m ()) -> m ()
-- displayMaybe d f = void . dyn $ maybe (pure ()) f <$> d

-- A more comprehensive alternative to a form
formNEW :: MonadWidget t m
            => UserShaped (FormletSimple t m)
            -> UserShaped (Validation (Either Text))
            -> Endpoint t m
            -> m ( Dynamic t (Either (UserShaped (Const (Maybe Text))) User)
                 , Event t (Either Text (Either (UserShaped (Const (Maybe Text))) User)) )
formNEW shapedWidget clientVal endpoint = do
  rec user <- form shapedWidget clientVal formErrorFromServer
      send <- buttonElement send responseEvent
      serverResponse <- let query = either (const $ Left "Please fill correctly the fields above") Right <$> user
                         in (fmap . fmap) parseReqResult (endpoint query send)
      let formErrorFromServer = fst . fanEither . snd . fanEither $ serverResponse
          responseEvent = () <$ serverResponse
  return (user, serverResponse)

--------------------------------------------------------------------------------
-- Implementation of the visual elements:

hiddenTitle, icon :: DomBuilder t m => m ()
hiddenTitle = elClass "h2" "sr-only" (text "Login Form")
icon = divClass "illustration" (elClass "i" "icon ion-ios-navigate" $ pure ())

mailInputConfig :: Reflex t => TextInputConfig t
mailInputConfig =
  def & textInputConfig_attributes .~ constDyn
        ("class" =: "form-control" <> "name" =: "email" <> "placeholder" =: "Email")
      & textInputConfig_inputType .~ "email"

passInputConfig :: Reflex t => TextInputConfig t
passInputConfig =
  def & textInputConfig_attributes .~ constDyn
        ("class" =: "form-control" <> "name" =: "password" <> "placeholder" =: "Password")
      & textInputConfig_inputType .~ "password"

buttonElement :: DomBuilder t m => Event t () -> Event t () -> m (Event t ())
buttonElement disable enable = divClass "form-group" $ do
  (e, _) <- element "button" conf (text "Log in")
  return (domEvent Click e)
  where
    conf = def & elementConfig_initialAttributes .~ initialAttr
               & elementConfig_modifyAttributes  .~ mergeWith (\_ b -> b)
                   [ const disableAttr <$> disable
                   , const enableAttr <$> enable ]
    initialAttr = "class" =: "btn btn-primary btn-block" <> "type" =: "button"
    disableAttr = fmap Just initialAttr  <> "disabled" =: Just "true"
    enableAttr  = fmap Just initialAttr  <> "disabled" =: Nothing

forgotYourUsername :: DomBuilder t m => m ()
forgotYourUsername = elAttr "a"
  ("href" =: "#" <> "class" =: "forgotYourUsername")
  (text "Forgot your email or password?")

userWidget :: (MonadWidget t m) => UserShaped (FormletSimple t m)
userWidget = UserShaped
  (FormletSimple $ userWidgetInternal mailInputConfig)
  (FormletSimple $ userWidgetInternal passInputConfig)

-- Forms for the shaped approach: This should be supplied by the user, as it's a
-- rendering of the particular markup the user wants for the form.
userWidgetInternal :: MonadWidget t m => TextInputConfig t -> Dynamic t (Maybe Text) -> m (Dynamic t Text)
userWidgetInternal conf err = do
  textBox   <- textInput conf
  firstBlur <- headE $ select (textBox ^. textInput_builderElement
                                        . to _inputElement_element
                                        . to _element_events)
                              (WrapArg Blur)
  displayedErr <- join <$> holdDyn (constDyn Nothing) (err <$ firstBlur)
  el "error" $ dynText (maybe "" id <$> displayedErr)
  return (value textBox)


--------------------------------------------------------------------------------
-- Things to be moved out of here
--------------------------------------------------------------------------------

--------------------------------------------------------------------------------
-- Parse the response from the API. This function could be in servant-reflex
-- (not in reflex-dom). In the meantime we'll keep it in shaped.
parseReqResult :: ReqResult a -> Either Text a
parseReqResult (ResponseSuccess a _) = Right a
parseReqResult (ResponseFailure t _) = Left t
parseReqResult (RequestFailure s)    = Left s

---------------------------------------------------------------------------------

-- This function is completely generic, should be moved in
-- Shaped.Validation.Reflex, or something
form :: MonadWidget t m
     => UserShaped (FormletSimple t m)            -- ^ a description of the widgets
     -> UserShaped (Validation (Either Text))     -- ^ the clientside validation
     -> Event t (UserShaped (Const (Maybe Text))) -- ^ Error from the server
     -> m (Dynamic t (Either (UserShaped (Const (Maybe Text))) User))
form shapedWidget shapedValidation errServer = mdo
  tentative <- createInterface (splitShaped errorEvent) shapedWidget
  let validationResult = transfGen . flip validateRecord shapedValidation <$> tentative
      errorEvent = leftmost [ updated $ either id (const nullError) <$> validationResult
                            , errServer ]
  return validationResult

type Endpoint t m = Dynamic t (Either Text User)
                 -> Event t ()
                 -> m (Event t (ReqResult (Either (UserShaped (Const (Maybe Text))) User)))


formAllIncluded :: MonadWidget t m
     => UserShaped (FormletSimple t m)            -- ^ a description of the widgets
     -> UserShaped (Validation (Either Text))     -- ^ the clientside validation
     -> Event t (UserShaped (Const (Maybe Text))) -- ^ Error from the server, to eliminate
     -> m (Dynamic t (Either (UserShaped (Const (Maybe Text))) User))
formAllIncluded shapedWidget shapedValidation errServer = mdo
  tentative <- createInterface (splitShaped errorEvent) shapedWidget
  let validationResult = transfGen . flip validateRecord shapedValidation <$> tentative
      errorEvent = leftmost [ updated $ either id (const nullError) <$> validationResult
                            , errServer ]
  return validationResult

-- We have to transform a:
-- eResult :: Event t (UserShaped (Const (Maybe Text)))
-- into a
-- nullError' :: UserShaped (Event t :.: Const (Maybe Text))
-- to feed it back recursively to the form.
-- This function seems completely general to me, so should be generalized and taken away
-- TODO: Generalize
-- TODO: Move
splitShaped :: Reflex t => Event t (UserShaped (Const (Maybe Text))) -> UserShaped (Event t :.: Const (Maybe Text))
splitShaped ev = UserShaped
{'fraction_non_alphanumeric': 0.15106882915926415, 'fraction_numerical': 0.002578944352111869, 'mean_word_length': 2.4865134865134864, 'pattern_counts': {'":': 0, '<': 73, '<?xml version=': 0, '>': 118, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 10, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '7580025', 'n_tokens_mistral': 4883, 'n_tokens_neox': 4709, 'n_words': 1688}