module Utils.Frontend.Modal ( Modal(..) , customModal , modal, msgModal , addMessageModal ) where import ClassyPrelude.Yesod import Control.Lens import Utils.Route import Utils.Message import Settings (widgetFile) import Control.Monad.Random.Class (uniform) import Control.Monad.Trans.Random (evalRandTIO) data Modal site = Modal { modalTriggerId , modalId :: Maybe Text , modalTrigger :: Maybe Text {- Dynamic URL -} -> Text {- TriggerId -} -> WidgetT site IO () , modalContent :: Either (SomeRoute site) (WidgetT site IO ()) } customModal :: Modal site -> WidgetT site IO () customModal Modal{..} = do triggerId' <- maybe newIdent return modalTriggerId $(widgetFile "widgets/modal/modal") route <- traverse toTextUrl $ modalContent ^? _Left modalTrigger route triggerId' -- | Create a link to a modal modal :: WidgetT site IO () -- ^ Widget that represents the link -> Either (SomeRoute site) (WidgetT site IO ()) -- ^ Modal contant: either dynamic link or static widget -> WidgetT site IO () -- ^ result widget modal modalTrigger' modalContent = customModal Modal{..} where modalTriggerId = Nothing modalId = Nothing modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") -- | Variant of `modal` for use in messages (uses a different id generator to avoid collisions) msgModal :: WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> WidgetT site IO () msgModal modalTrigger' modalContent = do let randomIdentifier :: MonadIO m => m Text -- ^ Generates valid CSS-Identifiers with roughly 128 bits of entropy -- -- See https://www.w3.org/TR/CSS21/syndata.html#value-def-identifier randomIdentifier = fmap pack . evalRandTIO $ do prefix <- uniform $ ['a'..'z'] ++ ['A'..'Z'] suffix <- replicateM 21 . uniform $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] return $ prefix : suffix modalTriggerId <- Just <$> randomIdentifier modalId <- Just <$> randomIdentifier customModal Modal{..} where modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger") -- | add message alert with a short trigger widget, whose larger content is displayed in a modal addMessageModal :: forall m site. ( MonadHandler m , HandlerSite m ~ site , Yesod site ) => MessageStatus -> WidgetT site IO () -> Either (SomeRoute site) (WidgetT site IO ()) -> m () addMessageModal ms trigger content = addMessageWidget ms $ msgModal trigger content