.. - serversession-backend-persistent ...
.. extra-deps: - serversession-backend-persistent-1.0.4
empeleryoshi $ stack build
-- Formの情報がここにはいる
data FileForm = FileForm {
fileInfo :: FileInfo
, inpText :: Text
}
fileUploadAFormInline :: Form FileForm
fileUploadAFormInline = renderBootstrap3 BootstrapInlineForm $ getAform
fileUploadAFormBasic :: Form FileForm
fileUploadAFormBasic = renderBootstrap3 BootstrapBasicForm $ getAform
fileUploadAFormHorizon :: Form FileForm
fileUploadAFormHorizon = renderBootstrap3 (BootstrapHorizontalForm (ColXs 2) (ColXs 8) (ColXs 2) (ColXs 6)) $ getAform
getAform :: AForm Handler FileForm
getAform = FileForm
<$> fileAFormReq fs <*> areq textField tfs Nothing
where fs = FieldSettings {
fsLabel = "ファイル"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Just "media"
, fsAttrs =
[ ("class", "form-group")
, ("placeholder", "File description")
]
}
tfs = FieldSettings {
fsLabel = "なんかいれろ"
, fsTooltip = Nothing
, fsId = Just "inptext"
, fsName = Just "inptext"
, fsAttrs =
[ ("class", "form-group form-control")
, ("placeholder", "input text")
]
}
getFormexamR :: Handler Html
getFormexamR = do
(formAWidgetBasic, formAEnctypeBasic) <- generateFormPost fileUploadAFormBasic
(formAWidgetInline, formAEnctypeInline) <- generateFormPost fileUploadAFormInline
(formAWidgetHorizon, formAEnctypeHorizon) <- generateFormPost fileUploadAFormHorizon
((res, widget), enctype) <- runFormPost fileUploadMForm
defaultLayout $ do
setTitle "Form Example!!!"
$(widgetFile "formexam")
fileUploadMForm :: Html -> MForm Handler (FormResult FileForm, Widget)
fileUploadMForm extra = do
let fsMedia = FieldSettings {
fsLabel = ""
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Just "media"
, fsAttrs =
[ ("class", "uploadFile")
, ("style", "display:none")
, ("placeholder", "")
]
}
let fsText = FieldSettings {
fsLabel = "なんか"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Just "inptext"
, fsAttrs =
[ ("class", "form-group form-control")
, ("placeholder", "")
]
}
(fileInfoRes, fileInfoView) <- mreq fileField fsMedia Nothing
(inpTextRes, inpTextView) <- mreq textField fsText Nothing
let fileRes = FileForm <$> fileInfoRes <*> inpTextRes
let widget = do
[whamlet|
#{extra}
<label>
<div class="form-group">
<span class="btn btn-default">Upload
^{fvInput fileInfoView}
^{fvInput inpTextView}
|]
return (fileRes, widget)
... ((res, widget), enctype) <- runFormPost fileUploadMForm ...
ugui7 ~ # emerge dev-haskell/erd
title {label: "nfldb Entity-Relationship diagram (condensed)", size: "20"}
# Entities
[player] {bgcolor: "#d0e0d0"}
*player_id {label: "varchar, not null"}
full_name {label: "varchar, null"}
team {label: "varchar, not null"}
position {label: "player_pos, not null"}
status {label: "player_status, not null"}
[team] {bgcolor: "#d0e0d0"}
*team_id {label: "varchar, not null"}
city {label: "varchar, not null"}
name {label: "varchar, not null"}
[game] {bgcolor: "#ececfc"}
*gsis_id {label: "gameid, not null"}
start_time {label: "utctime, not null"}
week {label: "usmallint, not null"}
season_year {label: "usmallint, not null"}
season_type {label: "season_phase, not null"}
finished {label: "boolean, not null"}
home_team {label: "varchar, not null"}
home_score {label: "usmallint, not null"}
away_team {label: "varchar, not null"}
away_score {label: "usmallint, not null"}
[drive] {bgcolor: "#ececfc"}
*+gsis_id {label: "gameid, not null"}
*drive_id {label: "usmallint, not null"}
start_field {label: "field_pos, null"}
start_time {label: "game_time, not null"}
end_field {label: "field_pos, null"}
end_time {label: "game_time, not null"}
pos_team {label: "varchar, not null"}
pos_time {label: "pos_period, null"}
[play] {bgcolor: "#ececfc"}
*+gsis_id {label: "gameid, not null"}
*+drive_id {label: "usmallint, not null"}
*play_id {label: "usmallint, not null"}
time {label: "game_time, not null"}
pos_team {label: "varchar, not null"}
yardline {label: "field_pos, null"}
down {label: "smallint, null"}
yards_to_go {label: "smallint, null"}
[play_player] {bgcolor: "#ececfc"}
*+gsis_id {label: "gameid, not null"}
*+drive_id {label: "usmallint, not null"}
*+play_id {label: "usmallint, not null"}
*+player_id {label: "varchar, not null"}
team {label: "varchar, not null"}
[meta] {bgcolor: "#fcecec"}
version {label: "smallint, null"}
season_type {label: "season_phase, null"}
season_year {label: "usmallint, null"}
week {label: "usmallint, null"}
# Relationships
player *--1 team
game *--1 team {label: "home"}
game *--1 team {label: "away"}
drive *--1 team
play *--1 team
play_player *--1 team
game 1--* drive
game 1--* play
game 1--* play_player
drive 1--* play
drive 1--* play_player
play 1--* play_player
player 1--* play_player
cuomo@ugui7 ~ $ erd -i sample.er -o simple.svg
database: user: "_env:MYSQL_USER:karky7" password: "_env:MYSQL_PASSWORD:hongani" host: "_env:MYSQL_HOST:localhost" port: "_env:MYSQL_PORT:3306" path: "_env:MYSQL_SOCK:/var/run/mysqld/mysqld.sock" # See config/test-settings.yml for an override during tests database: "_env:MYSQL_DATABASE:hongani" poolsize: "_env:MYSQL_POOLSIZE:10"
...
master <- getYesod
let dbconf = myConnInfo $ appDatabaseConf $ appSettings master
...
...
host = connectHost dbconf,
user = connectUser dbconf,
passwd = connectPassword dbconf,
db = connectDatabase dbconf,
port = (fromIntegral(connectPort dbconf) :: Int),
socket = connectPath dbconf
...
data ConnectInfo
= ConnectInfo {
connectHost :: String,
connectPort :: GHC.Word.Word16,
connectUser :: String,
connectPassword :: String,
connectDatabase :: String,
connectOptions :: [Database.MySQL.Base.Types.Option],
connectPath :: FilePath,
connectSSL :: Maybe SSLInfo
}
で定義されてる。database: ... path: "_env:MYSQL_SOCK:/var/run/mysqld/mysqld.sock" ...
~/Code/hongani $ export MYSQL_SOCK=/var/tmp/mysqld.sock ~/Code/hongani $ stack exec -- yesod devel Yesod devel server. Enter 'quit' or hit Ctrl-C to quit. Application can be accessed at: http://localhost:3000 https://localhost:3443 If you wish to test https capabilities, you should set the following variable: export APPROOT=https://localhost:3443 ...
... # Upload files store directory image-dir: "/home/cuomo/files/" ...
data AppSettings = AppSettings
{ appStaticDir :: String
-- ^ Directory from which to serve static files.
, appDatabaseConf :: MySQLConf
-- ^ Configuration settings for accessing the database.
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
, appHost :: HostPreference
-- ^ Host/interface the server should bind to.
, appPort :: Int
...
...
, appImageDir :: Text
-- ^ Image Stored Dir <==== ここら
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled.
}
...
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
...
appImageDir <- o .: "image-dir"
...
...
... master <- getYesod let imgDir = appImageDir $ appSettings master ...
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Home where
import Import
import qualified Data.Map as M
import qualified Data.Maybe as MB
import Database.Persist.MySQL (ConnectInfo(..), myConnInfo)
import Database.HDBC (execute, prepare, fetchAllRowsMap, SqlValue, fromSql)
import Database.HDBC.MySQL (Connection, MySQLConnectInfo(..),
defaultMySQLConnectInfo, connectMySQL)
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
data TekaUser = TekaUser {
tid :: Int64
, ident :: Text
, password :: Text
} deriving(Show, Eq)
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
getHomeR :: Handler Html
getHomeR = do
master <- getYesod
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
dbconf = myConnInfo $ appDatabaseConf $ appSettings master
tekkaTeka <- liftIO $ getDBConn dbconf >>= getTekkatekaUsers
$(logInfo) $ pack $ "=====> テカテカログ： " ++ show tekkaTeka
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
getTekkatekaUsers :: Connection -> IO ([TekaUser])
getTekkatekaUsers con = do
stm <- prepare con $ "SELECT u.* FROM user AS u UNION SELECT tu.* FROM tekateka_user AS tu"
_ <- execute stm []
rows <- fetchAllRowsMap stm
return $ MB.catMaybes $ toTeka rows
toTeka :: [M.Map String SqlValue] -> [Maybe TekaUser]
toTeka rows = map (\m -> TekaUser
`liftM` (fromSql <$> M.lookup "id" m)
`ap` (decodeUtf8 . fromSql <$> M.lookup "ident" m)
`ap` (decodeUtf8 . fromSql <$> M.lookup "password" m)) rows
getDBConn :: ConnectInfo -> IO Connection
getDBConn dbconf = connectMySQL defaultMySQLConnectInfo {
mysqlHost = connectHost dbconf,
mysqlUser = connectUser dbconf,
mysqlPassword = connectPassword dbconf,
mysqlDatabase = connectDatabase dbconf,
mysqlPort = (fromIntegral(connectPort dbconf) :: Int),
mysqlUnixSocket = "/var/run/mysqld/mysqld.sock"
}
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
