Application.hs

{-# LANGUAGE TypeFamilies, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts, GADTs #-}

import Yesod
import Yesod.Form
import Database.Persist
import Database.Persist.Sqlite
import Database.Persist.TH
import Data.Time
import Control.Applicative ((<$>), (<*>))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Maybe (isJust)
import Data.Aeson (FromJSON, decode, json')
import Data.Attoparsec (IResult(..), parse, maybeResult, endOfInput, feed)
import Data.ByteString (empty)

data JsonDB = JsonDB ConnectionPool

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
JsonEntry
  jsonText Text
  addTime UTCTime
  author Text Maybe
  description Text Maybe
|]

mkYesod "JsonDB" [parseRoutes|
/ HomeR GET
/json JsonR GET POST
/json/#JsonEntryId ShowJsonR GET
|]
instance Yesod JsonDB

instance RenderMessage JsonDB FormMessage where
    renderMessage _ _ = defaultFormMessage

instance YesodPersist JsonDB where
  type YesodPersistBackend JsonDB = SqlPersist
  runDB action = do
        JsonDB pool <- getYesod
        runSqlPool action pool

main = withSqlitePool ":memory:" 10 $ \pool-> do
    runSqlPool (runMigration migrateAll) pool
    warpDebug 8080 (JsonDB pool)

getHomeR :: Handler RepHtml
getHomeR = getJsonR

getJsonR :: Handler RepHtml
getJsonR = do
    entries <- runDB $ selectList [] [Desc JsonEntryAddTime, LimitTo 10]
    ((result, jsonFormWidget), enctype) <- runFormPost jsonForm
    defaultLayout [whamlet|
<p> Is this JSON?
<form method=post action=@{JsonR} enctype=#{enctype}>
  ^{jsonFormWidget}
  <input type=submit value=submit>
|]

postJsonR :: Handler RepHtml
postJsonR = do
    ((result, jsonFormWidget), enctype) <- runFormPost jsonForm
    case result of
      FormSuccess jsonInput -> defaultLayout [whamlet| amazing |]
      _ -> defaultLayout [whamlet|
<form method=post action=@{JsonR} enctype=#{enctype}>
  ^{jsonFormWidget}
<input type=submit value=submit>
|]

getShowJsonR :: JsonEntryId -> Handler RepHtml
getShowJsonR = undefined

jsonField :: (RenderMessage master FormMessage) => Field sub master Textarea
jsonField = checkBool validateJson ("Not valid json"::Text) textareaField
  where
    validateJson = isJust . maybeResult . flip feed empty
                   . (parse $ json' >> endOfInput) . encodeUtf8 . unTextarea

jsonForm :: Html -> MForm JsonDB JsonDB (FormResult JsonInput, Widget)
jsonForm tokenHtml = do
    (jsonRes, jsonView) <- mreq jsonField "" Nothing
    (authorRes, authorView) <- mopt textField "" Nothing
    (descRes, descView) <- mopt textField "" Nothing
    formInputId <- lift $ newIdent
    let jsonInputRes =
            JsonInput . unTextarea <$> jsonRes <*> authorRes <*> descRes

        widget = do
            toWidget [lucius|
##{formInputId} input {
  width: 600px;
}
##{fvId jsonView} {
  width: 600px;
  height: 400px;
}
|]
            [whamlet|
#{tokenHtml}
<div ##{formInputId}>
  <div ##{fvId jsonView}>
    <p>Json:
    ^{fvInput jsonView}
    $maybe error <- fvErrors jsonView
      <div .error>
        #{error}
  <div ##{fvId authorView}>
    <p>Author:
    ^{fvInput authorView}
  <div ##{fvId descView}>
    <p>Description:
    ^{fvInput descView}
|]


    return (jsonInputRes, widget)


data JsonInput = JsonInput {
      unJsonString :: Text
    , unAuthor :: Maybe Text
    , unDescription :: Maybe Text
}


{--
validateJson :: Textarea -> Either Text Textarea
validateJson textarea =
    case parseResult of
      Fail _ msgs msg -> Left (T.pack "Not valid json")
      Done _ _ -> Right textarea
      -- this will no occur, becauese of feeding empty to a parser
      Partial _ -> Left ""
  where
    parseResult = flip feed empty . (parse $ json' >> endOfInput)
                  . encodeUtf8 $ rawString
    rawString = unTextarea textarea
--}