Skip to content

Commit 71c891d

Browse files
tanakhtanakh
committed
add web app
1 parent 89840bb commit 71c891d

31 files changed

+5307
-0
lines changed

‎msgpack-idl-web/Application.hs

+61
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,61 @@
1+
{-# OPTIONS_GHC -fno-warn-orphans #-}
2+
module Application
3+
( makeApplication
4+
, getApplicationDev
5+
, makeFoundation
6+
) where
7+
8+
import Import
9+
import Settings
10+
import Yesod.Auth
11+
import Yesod.Default.Config
12+
import Yesod.Default.Main
13+
import Yesod.Default.Handlers
14+
import Yesod.Logger (Logger, logBS, toProduction)
15+
import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev)
16+
import qualified Database.Persist.Store
17+
import Database.Persist.GenericSql (runMigration)
18+
import Network.HTTP.Conduit (newManager, def)
19+
20+
-- Import all relevant handler modules here.
21+
-- Don't forget to add new modules to your cabal file!
22+
import Handler.Home
23+
24+
-- This line actually creates our YesodSite instance. It is the second half
25+
-- of the call to mkYesodData which occurs in Foundation.hs. Please see
26+
-- the comments there for more details.
27+
mkYesodDispatch "App" resourcesApp
28+
29+
-- This function allocates resources (such as a database connection pool),
30+
-- performs initialization and creates a WAI application. This is also the
31+
-- place to put your migrate statements to have automatic database
32+
-- migrations handled by Yesod.
33+
makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application
34+
makeApplication conf logger = do
35+
foundation <- makeFoundation conf setLogger
36+
app <- toWaiAppPlain foundation
37+
return $ logWare app
38+
where
39+
setLogger = if development then logger else toProduction logger
40+
logWare = if development then logCallbackDev (logBS setLogger)
41+
else logCallback (logBS setLogger)
42+
43+
makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App
44+
makeFoundation conf setLogger = do
45+
manager <- newManager def
46+
s <- staticSite
47+
dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf)
48+
Database.Persist.Store.loadConfig >>=
49+
Database.Persist.Store.applyEnv
50+
p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
51+
Database.Persist.Store.runPool dbconf (runMigration migrateAll) p
52+
return $ App conf setLogger s p manager dbconf
53+
54+
-- for yesod devel
55+
getApplicationDev :: IO (Int, Application)
56+
getApplicationDev =
57+
defaultDevelApp loader makeApplication
58+
where
59+
loader = loadConfig (configSettings Development)
60+
{ csParseExtra = parseExtra
61+
}

‎msgpack-idl-web/Foundation.hs

+162
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,162 @@
1+
module Foundation
2+
( App (..)
3+
, Route (..)
4+
, AppMessage (..)
5+
, resourcesApp
6+
, Handler
7+
, Widget
8+
, Form
9+
, maybeAuth
10+
, requireAuth
11+
, module Settings
12+
, module Model
13+
) where
14+
15+
import Prelude
16+
import Yesod
17+
import Yesod.Static
18+
import Yesod.Auth
19+
import Yesod.Auth.BrowserId
20+
import Yesod.Auth.GoogleEmail
21+
import Yesod.Default.Config
22+
import Yesod.Default.Util (addStaticContentExternal)
23+
import Yesod.Logger (Logger, logMsg, formatLogText)
24+
import Network.HTTP.Conduit (Manager)
25+
import qualified Settings
26+
import qualified Database.Persist.Store
27+
import Settings.StaticFiles
28+
import Database.Persist.GenericSql
29+
import Settings (widgetFile, Extra (..))
30+
import Model
31+
import Text.Jasmine (minifym)
32+
import Web.ClientSession (getKey)
33+
import Text.Hamlet (hamletFile)
34+
35+
-- | The site argument for your application. This can be a good place to
36+
-- keep settings and values requiring initialization before your application
37+
-- starts running, such as database connections. Every handler will have
38+
-- access to the data present here.
39+
data App = App
40+
{ settings :: AppConfig DefaultEnv Extra
41+
, getLogger :: Logger
42+
, getStatic :: Static -- ^ Settings for static file serving.
43+
, connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool.
44+
, httpManager :: Manager
45+
, persistConfig :: Settings.PersistConfig
46+
}
47+
48+
-- Set up i18n messages. See the message folder.
49+
mkMessage "App" "messages" "en"
50+
51+
-- This is where we define all of the routes in our application. For a full
52+
-- explanation of the syntax, please see:
53+
-- http://www.yesodweb.com/book/handler
54+
--
55+
-- This function does three things:
56+
--
57+
-- * Creates the route datatype AppRoute. Every valid URL in your
58+
-- application can be represented as a value of this type.
59+
-- * Creates the associated type:
60+
-- type instance Route App = AppRoute
61+
-- * Creates the value resourcesApp which contains information on the
62+
-- resources declared below. This is used in Handler.hs by the call to
63+
-- mkYesodDispatch
64+
--
65+
-- What this function does *not* do is create a YesodSite instance for
66+
-- App. Creating that instance requires all of the handler functions
67+
-- for our application to be in scope. However, the handler functions
68+
-- usually require access to the AppRoute datatype. Therefore, we
69+
-- split these actions into two functions and place them in separate files.
70+
mkYesodData "App" $(parseRoutesFile "config/routes")
71+
72+
type Form x = Html -> MForm App App (FormResult x, Widget)
73+
74+
-- Please see the documentation for the Yesod typeclass. There are a number
75+
-- of settings which can be configured by overriding methods here.
76+
instance Yesod App where
77+
approot = ApprootMaster $ appRoot . settings
78+
79+
-- Store session data on the client in encrypted cookies,
80+
-- default session idle timeout is 120 minutes
81+
makeSessionBackend _ = do
82+
key <- getKey "config/client_session_key.aes"
83+
return . Just $ clientSessionBackend key 120
84+
85+
defaultLayout widget = do
86+
master <- getYesod
87+
mmsg <- getMessage
88+
89+
-- We break up the default layout into two components:
90+
-- default-layout is the contents of the body tag, and
91+
-- default-layout-wrapper is the entire page. Since the final
92+
-- value passed to hamletToRepHtml cannot be a widget, this allows
93+
-- you to use normal widget features in default-layout.
94+
95+
pc <- widgetToPageContent $ do
96+
$(widgetFile "normalize")
97+
addStylesheet $ StaticR css_bootstrap_css
98+
$(widgetFile "default-layout")
99+
hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet")
100+
101+
-- This is done to provide an optimization for serving static files from
102+
-- a separate domain. Please see the staticRoot setting in Settings.hs
103+
urlRenderOverride y (StaticR s) =
104+
Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s
105+
urlRenderOverride _ _ = Nothing
106+
107+
-- The page to be redirected to when authentication is required.
108+
authRoute _ = Just $ AuthR LoginR
109+
110+
messageLogger y loc level msg =
111+
formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y)
112+
113+
-- This function creates static content files in the static folder
114+
-- and names them based on a hash of their content. This allows
115+
-- expiration dates to be set far in the future without worry of
116+
-- users receiving stale content.
117+
addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute [])
118+
119+
-- Place Javascript at bottom of the body tag so the rest of the page loads first
120+
jsLoader _ = BottomOfBody
121+
122+
-- How to run database actions.
123+
instance YesodPersist App where
124+
type YesodPersistBackend App = SqlPersist
125+
runDB f = do
126+
master <- getYesod
127+
Database.Persist.Store.runPool
128+
(persistConfig master)
129+
f
130+
(connPool master)
131+
132+
instance YesodAuth App where
133+
type AuthId App = UserId
134+
135+
-- Where to send a user after successful login
136+
loginDest _ = HomeR
137+
-- Where to send a user after logout
138+
logoutDest _ = HomeR
139+
140+
getAuthId creds = runDB $ do
141+
x <- getBy $ UniqueUser $ credsIdent creds
142+
case x of
143+
Just (Entity uid _) -> return $ Just uid
144+
Nothing -> do
145+
fmap Just $ insert $ User (credsIdent creds) Nothing
146+
147+
-- You can add other plugins like BrowserID, email or OAuth here
148+
authPlugins _ = [authBrowserId, authGoogleEmail]
149+
150+
authHttpManager = httpManager
151+
152+
-- This instance is required to use forms. You can modify renderMessage to
153+
-- achieve customized and internationalized form validation messages.
154+
instance RenderMessage App FormMessage where
155+
renderMessage _ _ = defaultFormMessage
156+
157+
-- Note: previous versions of the scaffolding included a deliver function to
158+
-- send emails. Unfortunately, there are too many different options for us to
159+
-- give a reasonable default. Instead, the information is available on the
160+
-- wiki:
161+
--
162+
-- https://github.com/yesodweb/yesod/wiki/Sending-email

‎msgpack-idl-web/Handler/Home.hs

+59
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,59 @@
1+
{-# LANGUAGE TupleSections, OverloadedStrings, ViewPatterns #-}
2+
module Handler.Home where
3+
4+
import Import
5+
6+
import Data.Maybe
7+
import qualified Data.Text.Lazy as LT
8+
import qualified Filesystem as FS
9+
import Shelly
10+
import Text.Shakespeare.Text
11+
12+
defaultCode :: Text
13+
defaultCode = [st|
14+
message hoge {
15+
0: int moge
16+
1: map<string, double> hage
17+
}
18+
19+
service test {
20+
void foo(0: hoge x)
21+
}
22+
|]
23+
24+
getHomeR :: Handler RepHtml
25+
getHomeR = do
26+
let submission = Nothing :: Maybe (FileInfo, Text)
27+
handlerName = "getHomeR" :: Text
28+
defaultLayout $ do
29+
aDomId <- lift newIdent
30+
setTitle "MessagePack IDL Code Generator"
31+
$(widgetFile "homepage")
32+
33+
postHomeR :: Handler (ContentType, Content)
34+
postHomeR = do
35+
(fromMaybe "noname" -> name, source, lang, namespace) <- runInputPost $ (,,,)
36+
<$> iopt textField "name"
37+
<*> ireq textField "source"
38+
<*> ireq textField "lang"
39+
<*> iopt textField "namespace"
40+
41+
let tarname = [lt|#{name}.tar.bz2|]
42+
idlname = [lt|#{name}.idl|]
43+
44+
let opts = map LT.fromStrict $ case (lang, namespace) of
45+
("cpp", Just ns) -> ["-n", ns]
46+
("java", Just pn) -> ["-p", pn]
47+
("ruby", Just mn) -> ["-m", mn]
48+
_ -> []
49+
50+
archive <- shelly $ do
51+
withTmpDir $ \tmppath -> chdir tmppath $ do
52+
writefile (fromText idlname) $ LT.fromStrict source
53+
run_ "mpidl" $ [LT.fromStrict lang, "-o", [lt|#{name}|], idlname] ++ opts
54+
run_ "tar" ["-cjf", tarname, [lt|#{name}|]]
55+
p <- pwd
56+
liftIO $ FS.readFile $ p </> fromText tarname
57+
58+
setHeader "Content-Disposition" [st|attachment; filename="#{tarname}"|]
59+
return ("application/x-bz2", toContent archive)

‎msgpack-idl-web/Import.hs

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
module Import
2+
( module Prelude
3+
, module Yesod
4+
, module Foundation
5+
, module Settings.StaticFiles
6+
, module Settings.Development
7+
, module Data.Monoid
8+
, module Control.Applicative
9+
, Text
10+
#if __GLASGOW_HASKELL__ < 704
11+
, (<>)
12+
#endif
13+
) where
14+
15+
import Prelude hiding (writeFile, readFile, head, tail, init, last)
16+
import Yesod hiding (Route(..))
17+
import Foundation
18+
import Data.Monoid (Monoid (mappend, mempty, mconcat))
19+
import Control.Applicative ((<$>), (<*>), pure)
20+
import Data.Text (Text)
21+
import Settings.StaticFiles
22+
import Settings.Development
23+
24+
#if __GLASGOW_HASKELL__ < 704
25+
infixr 5 <>
26+
(<>) :: Monoid m => m -> m -> m
27+
(<>) = mappend
28+
#endif

‎msgpack-idl-web/LICENSE

+25
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
The following license covers this documentation, and the source code, except
2+
where otherwise indicated.
3+
4+
Copyright 2012, Hideyuki Tanaka. All rights reserved.
5+
6+
Redistribution and use in source and binary forms, with or without
7+
modification, are permitted provided that the following conditions are met:
8+
9+
* Redistributions of source code must retain the above copyright notice, this
10+
list of conditions and the following disclaimer.
11+
12+
* Redistributions in binary form must reproduce the above copyright notice,
13+
this list of conditions and the following disclaimer in the documentation
14+
and/or other materials provided with the distribution.
15+
16+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+
EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+
OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+
OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+
ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

‎msgpack-idl-web/Model.hs

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
module Model where
2+
3+
import Prelude
4+
import Yesod
5+
import Data.Text (Text)
6+
import Database.Persist.Quasi
7+
8+
9+
-- You can define all of your database entities in the entities file.
10+
-- You can find more information on persistent and how to declare entities
11+
-- at:
12+
-- http://www.yesodweb.com/book/persistent/
13+
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
14+
$(persistFileWith lowerCaseSettings "config/models")

0 commit comments

Comments
 (0)