Permalink
Browse files

Switch incoming.julius to Fay

  • Loading branch information...
snoyberg committed Oct 28, 2012
1 parent 3e20ba9 commit f7527feab714a90a0b9a28c5eef81e5e43361d8b
View
@@ -4,3 +4,5 @@ dist/
config/client_session_key.aes
photosorter.sqlite3
photosorter.keter
*.o
*.hi
View
@@ -30,6 +30,7 @@ import Handler.SetName
import Handler.SetDescription
import Handler.ToPostList
import Handler.UnPost
import Handler.Command
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
View
@@ -0,0 +1,45 @@
module Handler.Command where
import Import
import SharedTypes
import Data.Aeson (decode)
import Language.Fay.Convert
import qualified Data.ByteString.Lazy as L
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
type HandleCommand = forall s. (forall a. Show a => Returns a -> a -> Handler s) -> Command -> Handler s
handle :: HandleCommand -> Handler RepJson
handle f = do
mtxt <- lookupPostParam "json"
case mtxt of
Nothing -> error "No JSON provided"
Just txt ->
case decode (L.fromChunks [encodeUtf8 txt]) >>= readFromFay of
Nothing -> error $ "Unable to parse input: " ++ show txt
Just cmd -> f go cmd
where
go Returns = jsonToRepJson . showToFay
handleCommand :: HandleCommand
handleCommand respond command =
case command of
AddPost date slug r -> do
liftIO $ addPost $ PostName $ T.pack $ filter (/= '-') date ++ slug
respond r ()
SetPost f' p' r -> do
let f = FilePath' $ T.pack f'
p = PostName $ T.pack p'
runDB $ do
x <- getBy $ UniqueMedia f
case x of
Nothing -> do
_ <- insert $ Media f (Just p)
return ()
Just (Entity key val) -> do
replace key $ val { mediaPost = Just p }
respond r ()
postCommandR :: Handler RepJson
postCommandR = handle handleCommand
View
@@ -17,6 +17,7 @@ getIncomingR root = do
defaultLayout $ do
setTitle "Incoming"
$(widgetFile "incoming")
$(fayFile "Incoming")
addScriptEither $ urlJqueryJs y
where
isChosen Nothing _ = False
View
@@ -21,6 +21,7 @@ import Control.Monad (foldM, filterM)
import Data.List (sortBy, sort)
import Data.Ord (comparing)
import Control.Arrow ((&&&))
import Import.Fay as Import
#if __GLASGOW_HASKELL__ >= 704
import Data.Monoid as Import
View
@@ -0,0 +1,49 @@
module Import.Fay
( fayFile
) where
import Prelude
import Yesod
import Language.Haskell.TH.Syntax
import Language.Fay.Compiler
import Language.Fay.Types
import Data.Default (def)
import Text.Julius
import qualified Data.Text as T
import Data.Text.Lazy.Builder (fromText)
import Settings.Development (development)
import System.Process (rawSystem)
import System.Exit (ExitCode (ExitSuccess))
import Control.Monad (unless)
fayFile :: String -> Q Exp
fayFile
| development = fayFileReload
| otherwise = fayFileProd
fayFileProd :: String -> Q Exp
fayFileProd name = do
qAddDependentFile fp
ec <- qRunIO $ rawSystem "ghc" ["-O0", "--make", "-ifay", "-ifay-shared", fp]
unless (ec == ExitSuccess) $ error $ "Type checking of fay module failed: " ++ name
eres <- qRunIO $ compileFile config fp
case eres of
Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
Right s -> [|toWidget $ const $ Javascript $ fromText $ T.pack s|]
where
fp = mkfp name
mkfp :: String -> FilePath
mkfp name = "fay/" ++ name ++ ".hs"
config :: CompileConfig
config = def
{ configDirectoryIncludes = ["fay", "fay-shared"]
}
fayFileReload :: String -> Q Exp
fayFileReload name = [|
liftIO (compileFile config $ mkfp name) >>= \eres ->
(case eres of
Left e -> error $ "Unable to compile Fay module \"" ++ name ++ "\": " ++ show e
Right s -> toWidget $ const $ Javascript $ fromText $ T.pack s)|]
View
@@ -16,3 +16,4 @@
/set-description SetDescriptionR POST
/topost ToPostListR GET
/topost/#PostName/unpost UnPostR POST
/json CommandR POST
View
@@ -0,0 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-}
module SharedTypes where
import Language.Fay.Prelude
import Language.Fay.FFI
data Returns a = Returns
deriving (Show, Read, Data, Typeable)
data Command = AddPost String String (Returns ())
| SetPost String String (Returns ())
deriving (Show, Read, Data, Typeable)
instance Foreign Command
View
@@ -0,0 +1,22 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Client.API where
import SharedTypes
import Language.Fay.FFI
import Language.Fay.Prelude
-- | Call a command.
call :: (Foreign a) => (Returns a -> Command) -> (a -> Fay ()) -> Fay ()
call f g = ajaxCommand (f Returns) g
-- | Run the AJAX command.
ajaxCommand :: (Foreign a) => Command -> (a -> Fay ()) -> Fay ()
ajaxCommand = ffi "jQuery['ajax']({\
\ \"url\": '/json', \
\ \"type\": 'POST', \
\ \"data\": { \"json\": JSON.stringify(%1) }, \
\ \"dataType\": 'json', \
\ \"success\" : %2 \
\})"
View
@@ -0,0 +1,33 @@
{-# LANGUAGE NoImplicitPrelude #-}
module Incoming where
import Language.Fay.Prelude
import Language.Fay.JQuery
import Language.Fay.DOM
import Language.Fay.FFI
import Client.API
import SharedTypes
main :: Fay ()
main = ready $ do
select "button.add-new-post" >>= onClick (\e -> do
alert' "You clicked the button"
eventSource e >>= hide >>= next >>= unhide
return False
)
select "button.add-new-post2" >>= onClick (\e -> do
t <- eventSource e
date <- parent t >>= childrenMatching "input[type=date]" >>= getVal
slug <- parent t >>= childrenMatching "input[type=text]" >>= getVal
call (AddPost date slug) $ const reload
return False
)
select "input[type=radio]" >>= onClick (\e -> do
t <- eventSource e
file <- parentsSelector "form" t >>= childrenMatching "input[name=file]" >>= getVal
post <- getVal t
call (SetPost file post) $ const $ return ()
return False
)
return ()
View
@@ -0,0 +1,36 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Language.Fay.DOM where
import Language.Fay.FFI
import Language.Fay.Prelude
data Element
instance Foreign Element
-- | Get body.
getBody :: Fay Element
getBody = ffi "document['body']"
data Timer
instance Foreign Timer
-- | Set a timer.
setTimeout :: Double -> Fay () -> Fay Timer
setTimeout = ffi "window['setTimeout'](%2,%1)"
-- | Set a timer.
setInterval :: Double -> Fay () -> Fay Timer
setInterval = ffi "window['setInterval'](%2,%1)"
-- | Clear a timer.
clearTimeout :: Timer -> Fay ()
clearTimeout = ffi "window['clearTimeout'](%1)"
alert :: String -> Fay ()
alert = ffi "window.alert(%1)"
reload :: Fay ()
reload = ffi "window.location.reload()"
Oops, something went wrong.

0 comments on commit f7527fe

Please sign in to comment.