content: module Main (main) where
  
  import           ClassyPrelude
  import           Control.Concurrent.Lifted
  import           Control.Monad.Logger (runStderrLoggingT)
  import           Data.CaseInsensitive (original)
  import           Data.Char (isAlphaNum)
  import qualified Data.Configurator as Conf
  import           Database
  import           Mailer
  import           Network.HTTP.Types
  import           Network.Wai (Application)
  import qualified Network.Wai as Wai
  import qualified Network.Wai.Handler.Warp as Warp
  import           Network.Wai.Handler.WebSockets (websocketsOr)
  import           Network.WebSockets.Connection (defaultConnectionOptions)
  import           Routes
  import qualified Sockets
  import           System.Random (getStdRandom, randomR)
  import           Web.Scotty
  
  maybeParam :: Parsable a => LText -> ActionM (Maybe a)
  maybeParam name = (Just <$> param name) `rescue` (pure . const Nothing)
  
  defaultParam :: Parsable a => LText -> a -> ActionM a
  defaultParam name def = param name `rescue` (pure . const def)
  
  validated :: Parsable a => (a -> Bool) -> LText -> ActionM a -> ActionM a
  validated f errorMessage val = do
    inner <- val
    if f inner then
      val
    else
      raise errorMessage
  
  maybeHeader :: HeaderName -> ActionM (Maybe Text)
  maybeHeader name = (listToMaybe . map (decodeUtf8 . snd)
                     . filter ((== name) . fst) . Wai.requestHeaders) <$> request
  
  getHeader :: HeaderName -> ActionM Text
  getHeader name = maybe (raise message) pure =<< maybeHeader name
    where message = "missing \"" <> headerName <> "\" header"
          headerName = (fromStrict . decodeUtf8 . original) name
  
  route :: Database
        -> Chan (EmailAddress, Code)
        -> Chan ResolvedPost
        -> (ActionM () -> ScottyM ())
        -> ActionM (Either Response Request)
        -> ScottyM ()
  route db emailChan socketChan path makeReq = path $ do
    reqOrRes <- makeReq
    let dbRes = either pure execute reqOrRes
    res <- liftIO (runReaderT dbRes db)
    effects <- send res
    mapM_ (liftIO . perform) effects
    where
      perform :: SideEffect -> IO ()
      perform (SendEmail emailAddress code) =
        writeChan emailChan (emailAddress, code)
      perform (SocketUpdate p) =
        writeChan socketChan p
  
  simpleRoute :: Database
              -> Chan (EmailAddress, Code)
              -> Chan ResolvedPost
              -> (ActionM () -> ScottyM ())
              -> ActionM Request -> ScottyM ()
  simpleRoute db emailChan socketChan path makeReq = route db emailChan socketChan path $
    (Right <$> makeReq) `rescue` (pure . Left . BadRequest)
  
  execute :: Request -> DatabaseM Response
  execute (GetPost idPost) = maybe (PostNotFound idPost) ExistingPost <$> getPost idPost
  execute (ListPosts query) = PostList <$> getPosts query
  execute (CreatePost idParent token content) =
    maybe (pure BadToken) makePost =<< getUserByToken token
    where makePost user = do
            maybePost <- createPost user content idParent
            pure $ case (idParent, maybePost) of
              (_, Just post) -> NewPost post
              (Just idParent, Nothing) -> PostNotFound idParent
              (Nothing, Nothing) -> error "creating top-level posts should never fail"
  execute (CreateCode emailAddress) =
    maybe UnknownEmail NewCode <$> createCode emailAddress
  execute (CreateToken code) =
    maybe (pure BadCode) (fmap NewToken . withUser) =<< createToken code
    where
      noUser = error "we created a token but then couldn't find the user"
      withUser token@TokenRecord{tokenUserID} =
        maybe noUser (ResolvedToken token) <$> getUser tokenUserID
  execute (CreateUser email name) =
    maybe (pure ExistingNameOrEmail) withCode =<< createUser email name
    where withCode User{userEmail} = maybe noCode NewUser <$> createCode userEmail
          noCode = error "failed to create code for new user"
  
  data SideEffect = SendEmail EmailAddress Code
                  | SocketUpdate ResolvedPost
  
  done :: ActionM [SideEffect]
  done = pure []
  
  send :: Response -> ActionM [SideEffect]
  send (NewPost p) = json p $> [SocketUpdate p]
  send (ExistingPost p) = json p *> done
  send (PostList ps) = json ps *> done
  send (NewToken t) = json t *> done
  send (NewUser resolvedCode@(ResolvedCode _ user)) = json user *> send (NewCode resolvedCode)
  send (NewCode (ResolvedCode code user)) = pure [SendEmail (userEmail user) (codeValue code)]
  send BadToken = status status401 *> text "invalid token" *> done
  send BadCode = status status401 *> text "invalid code" *> done
  send UnknownEmail = status status200 *> done
  send InvalidUsername = status status400 *> text "invalid username" *> done
  send ExistingNameOrEmail = status status409 *> text "username or email address taken" *> done
  send (BadRequest message) = status status400 *> text message *> done
  send (PostNotFound idPost) = status status404 *> text message *> done
    where message = mconcat ["post ", tlshow idPost, " not found"]
  
  isLegalLimit :: Int -> Bool
  isLegalLimit x
    | x < 1 = False
    | x > 500 = False
    | otherwise = True
  
  basilica :: Maybe ByteString
           -> Database
           -> Chan (EmailAddress, Code)
           -> Chan ResolvedPost
           -> IO Application
  basilica origin db emailChan socketChan = scottyApp $ do
    case origin of
      Nothing -> pure ()
      Just o -> do
        middleware (addHeaders [("Access-Control-Allow-Origin", o)])
        addroute OPTIONS (function $ const $ Just []) $ do
          setHeader "Access-Control-Allow-Headers" "X-Token"
          setHeader "Access-Control-Allow-Methods" "GET, POST, PUT, PATCH, DELETE, OPTIONS"
          status status200
  
    let simple = simpleRoute db emailChan socketChan
  
    let limit = validated isLegalLimit "limit out of range"
                          (defaultParam "limit" 200)
    simple (get "/posts") (ListPosts <$> (PostQuery <$> maybeParam "before"
                                                    <*> maybeParam "after"
                                                    <*> limit))
    simple (get "/posts/:id") (GetPost <$> param "id")
    simple (post "/posts") (CreatePost Nothing <$> getHeader "X-Token"
                                               <*> param "content")
    simple (post "/posts/:id") (CreatePost <$> (Just <$> param "id")
                                           <*> getHeader "X-Token"
                                           <*> param "content")
    simple (post "/codes") (CreateCode <$> param "email")
    simple (post "/tokens") (CreateToken <$> param "code")
  
    route db emailChan socketChan (post "/users") $ do
      name <- param "name"
      if isValidName name then
        (fmap Right . CreateUser) <$> param "email" <*> pure name
      else
        pure (Left InvalidUsername)
  
  isValidName :: Text -> Bool
  isValidName name = all isAlphaNum name && (len >= 2) && (len < 20)
    where len = length name
  
  addHeaders :: ResponseHeaders -> Wai.Middleware
  addHeaders newHeaders app req respond = app req $ \response -> do
    let (st, currentHeaders, streamHandle) = Wai.responseToStream response
    streamHandle $ \streamBody ->
      respond $ Wai.responseStream st (currentHeaders ++ newHeaders) streamBody
  
  randomSubject :: IO Text
  randomSubject = (subjects `indexEx`) <$> getStdRandom (randomR (0, length subjects - 1))
    where subjects = [ "Hey Beautiful"
                     , "Hey Baby"
                     , "Hey Hon"
                     , "Hey Honey"
                     , "Hey Girl"
                     , "Hey Sugarlips"
                     , "Hey Darling"
                     , "Hey Buttercup"
                     , "Hey Honeyfingers"
                     , "Hey Syruptoes"
                     ]
  
  sendCodeMail :: Mailer -> Text -> (EmailAddress, Code) -> IO ()
  sendCodeMail mailer clientUrl (to, code) = do
    subject <- randomSubject
    sendMail mailer (easyEmail to subject messageBody)
    where messageBody = intercalate "\n"
                        [ "Here's your Basilicode:"
                        , ""
                        , code
                        , ""
                        , "And a handy login link:"
                        , ""
                        , clientUrl <> "/login?code=" <> code
                        , ""
                        , "Love,"
                        , "  Basilica"
                        ]
  
  logCode :: (EmailAddress, Code) -> IO ()
  logCode (to, code) = putStrLn (intercalate ": " [to, code])
  
  main :: IO ()
  main = do
    conf <- Conf.load [Conf.Required "conf"]
    port <- Conf.require conf "port"
    origin <- Conf.lookup conf "client-origin"
    mailgunKey <- Conf.lookup conf "mailgun-key"
    mailHandler <- case mailgunKey of
      Nothing -> pure logCode
      Just key -> sendCodeMail (newMailer key) <$> Conf.require conf "client-url"
    emailChan <- newChan
    socketChan <- newChan
    server <- Sockets.newServer socketChan
    _ <- fork $ getChanContents emailChan >>= mapM_ mailHandler
  
    dbPath <- Conf.require conf "dbpath"
    runStderrLoggingT $ withDatabase dbPath $ \db ->
      liftIO $ do
        api <- basilica origin db emailChan socketChan
        putStrLn $ "Running on port " ++ tshow port
        Warp.run port (websocketsOr defaultConnectionOptions server api)
  