git.gnu.io has moved to IP address 209.51.188.249 -- please double check where you are logging in.

Remove some unused modules

parent 5b12c700
......@@ -48,8 +48,6 @@ library
Css
Data.Filter
Data.Order
Data.Text.PrettyHtml
Data.Tree.Extra
Dev
DeprecatedBootstrap
Foundation
......@@ -58,7 +56,6 @@ library
Handler.HonorPledge
Handler.Invitation
Handler.JsLicenses
Handler.MarkdownTutorial
Handler.NewDesign
Handler.PostLogin
Handler.Project
......@@ -93,42 +90,29 @@ library
Model.Discussion.TH
Model.Language
Model.Language.TH
Model.License
Model.License.Internal
Model.Markdown
Model.Markdown.Diff
Model.Permission.Internal
Model.Project
Model.Project.Signup
Model.Project.Signup.Internal
Model.ResetPassphrase
Model.Role
Model.Settings
Model.Shares
Model.TH
Model.Tag
Model.Transaction
Model.User
Model.User.Internal
Model.User.Sql
Model.Utils
Model.ViewType
Model.Volunteer
Settings
Settings.Development
Settings.StaticFiles
Version
View.Project
View.Project.Signup
View.ResetPassphrase
View.Time
View.User
Widgets.Markdown
Widgets.Navbar
Widgets.Preview
Widgets.Search
Widgets.Tag
Widgets.UserPledges
WrappedValues
-- other-modules {{{2
......
{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Data.Text.PrettyHtml (unlinesHtml, prettyHtml, prettyThings) where
import Import.NoFoundation
import Control.Applicative
import Data.Attoparsec.Text
import Data.List as L
import Data.String
import Data.Text as T
import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html
unlinesHtml :: [Html] -> Html
unlinesHtml = sequence_ . L.intersperse Html.br
-- | Single step of a 'Data.List.foldr' to concatenate 'Right's in an 'Either'
-- and remove empty 'Right's.
concatRights :: Either a T.Text -> [Either a T.Text] -> [Either a T.Text]
concatRights (Right y) xs | T.null y = xs
concatRights (Right y) (Right x : xs) = Right (y `T.append` x) : xs
concatRights y xs = y : xs
prettyHtml :: (Monad m, HasGithubRepo (HandlerT site m)) => [Parser Pretty] -> Text -> HandlerT site m Html
prettyHtml filters text =
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do
let pieces = L.foldr concatRights [] result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
Left err -> error err
renderPretty :: (Monad m, HasGithubRepo (HandlerT site m)) => Pretty -> HandlerT site m Html
renderPretty pretty = case pretty of
RawHtml html -> return html
GithubTicket int -> do
maybe_github_repo_link <- getGithubRepo
let github_issue = toHtml $ "Github issue " ++ show int
return $ case maybe_github_repo_link of
Just github_repo_link -> Html.a github_issue Html.! Attr.href
(fromString $ "https://github.com/" ++ T.unpack github_repo_link ++ "/issues/" ++ show int)
Nothing -> github_issue
data Pretty = GithubTicket Int | RawHtml Html
githubTicketRef :: Parser Pretty
githubTicketRef = GithubTicket <$> (asciiCI "GH-" *> decimal)
prettyThings :: [Parser Pretty]
prettyThings = [githubTicketRef]
module Data.Tree.Extra where
import Prelude (Ordering, (.), map)
import Data.List (sortBy)
import Data.Tree (Forest, Tree(..))
sortTreeBy :: (Tree a -> Tree a -> Ordering) -> Tree a -> Tree a
sortTreeBy f (Node x xs) = Node x (sortForestBy f xs)
sortForestBy :: (Tree a -> Tree a -> Ordering) -> Forest a -> Forest a
sortForestBy f = sortBy f . map (sortTreeBy f)
singleton :: a -> Tree a
singleton x = Node x []
This diff is collapsed.
module Handler.Discussion where
import Import
import Model.Comment.Sql
-- | Given a callback that takes a "root comment getter", call the callback with the appropriate
-- "root comment getter", by looking for a "state=open" or "state=closed" GET param.
getDiscussion
:: Maybe Text
-> ((DiscussionId -> ExprCommentCond -> DB [Entity Comment]) -> Handler Html)
-> Handler Html
getDiscussion closedView callback =
case closedView of
Just "closed" -> callback fetchDiscussionClosedOrRetractedRootCommentsDB
-- Not "closed"? Just accept anything else as meaning "open".
_ -> callback fetchDiscussionRootCommentsDB
module Handler.MarkdownTutorial where
import Import
import Handler.Utils
getMarkdownTutorialR :: Handler Html
getMarkdownTutorialR = defaultLayout $ do
snowdriftTitle "Markdown Tutorial"
$(widgetFile "markdown")
module Handler.User.Create where
import Import
import Data.Maybe (fromJust)
import Handler.Utils
import View.User
getUserCreateR :: Handler Html
getUserCreateR = do
(form, _) <- generateFormPost $ createUserForm Nothing
defaultLayout $ do
snowdriftTitle "Create User"
[whamlet|
<form method=POST>
^{form}
<input type=submit>
|]
-- | This needs to be placed in a folder/module for emails.
startEmailVerification :: UserId -> Text -> HandlerT App IO ()
startEmailVerification user_id user_email = do
hash <- liftIO newHash
ver_uri <- getUrlRender <*> (pure $ UserVerifyEmailR user_id hash)
runDB $ do
insert_ $ EmailVerification user_id user_email ver_uri False
update $ \u -> do
set u $ [UserEmail_verified =. val False]
where_ $ u ^. UserId ==. val user_id
alertSuccess $ "Verification email has been sent to " <> user_email <> "."
postUserCreateR :: Handler Html
postUserCreateR = do
((result, form), _) <- runFormPost $ createUserForm Nothing
case result of
FormSuccess (ident, passph, name, memail, avatar, nick) -> do
createUser ident
(Just passph)
name
(NewEmail False <$> memail)
avatar
nick
>>= \muser_id -> when (isJust muser_id) $ do
when (isJust memail) $ do
let email = fromJust memail
user_id = fromJust muser_id
startEmailVerification user_id email
setCreds True $ Creds "hashdb" ident []
redirectUltDest HomeR
FormMissing -> alertDanger "missing field"
FormFailure strings -> alertDanger (mconcat strings)
defaultLayout $ [whamlet|
<form method=POST>
^{form}
<input type=submit>
|]
module Model.License where
import Import
fetchLicensesDB :: DB [License]
fetchLicensesDB =
fmap (map entityVal) $
select $ from $ \(l :: SqlExpr (Entity License)) ->
return l
\ No newline at end of file
module Model.Permission.Internal where
import Prelude
import Data.Text as T
import Database.Persist.TH
import Debug.Trace
import Web.PathPieces
data PermissionLevel = Public | Normal | Moderated
deriving (Eq, Show, Read, Ord, Enum, Bounded)
derivePersistField "PermissionLevel"
instance PathPiece PermissionLevel where
fromPathPiece s =
if T.null s then Nothing else Just (read $ traceShow s $ T.unpack s)
toPathPiece = T.pack . show
module Model.Settings where
import Import
import Data.Typeable
import Model.Settings.Internal
data UserSettings = UserSettings { userSettingsShowTagVotes :: Bool }
deriving (Typeable)
defaultUserSettings :: UserSettings
defaultUserSettings = UserSettings { userSettingsShowTagVotes = False }
getUserSettings :: Handler UserSettings
getUserSettings = cached $ do
maybe_user_id <- maybeAuthId
case maybe_user_id of
Nothing -> return defaultUserSettings
Just user_id -> do
ss <- runDB $ select $ from $ \user_setting -> do
where_ $ user_setting ^. UserSettingUser ==. val user_id
return user_setting
return $
foldl applyUserSetting defaultUserSettings $ map entityVal ss
applyUserSetting :: UserSettings -> UserSetting -> UserSettings
applyUserSetting
user_settings
setting@(UserSetting { userSettingSetting = ShowTagVotes }) =
user_settings { userSettingsShowTagVotes = read (userSettingValue setting) }
{-# LANGUAGE RecordWildCards #-}
module Model.TH where
import Prelude
import Control.Monad
import Data.Char
import Data.Monoid
import Database.Persist.Types
import Language.Haskell.TH
import qualified Data.List as L
import qualified Data.Text as T
mkReferences :: String -> [EntityDef] -> Q [Dec]
mkReferences name defs = do
let references = do
EntityDef {..} <- defs
FieldDef {..} <- entityFields
guard $ fieldType == FTTypeCon Nothing (T.pack name <> "Id")
return $
map (ucHead . T.unpack . unHaskellName)
[entityHaskell, fieldHaskell]
ucHead [] = []
ucHead (c:cs) = toUpper c : cs
mkTypeConstructor names =
NormalC (mkName $ L.intercalate "_" $ name <> "Ref" : names) []
return
[ DataD
[]
(mkName $ name <> "Reference")
[]
(map
mkTypeConstructor
references)
[mkName "Bounded", mkName "Enum"]]
module Model.Tag
( AnnotatedTag(..)
, Color(..)
, annotTagName
, annotTagScore
, annotTagScoreString
, annotTagUserScore
, sortAnnotTagsByName
, sortAnnotTagsByScore
, fetchAllTagsDB
, fetchTagsInDB
, fetchTagColorsDB
, fetchDefaultTagColorsDB
) where
import Import hiding (Color)
import Data.List (sortBy)
import Text.Printf
import qualified Data.List as L
import qualified Data.Map as M
newtype Color = Color Int deriving (Num)
fetchAllTagsDB :: DB [Entity Tag]
fetchAllTagsDB = select (from return)
fetchTagsInDB :: [TagId] -> DB [Entity Tag]
fetchTagsInDB tag_ids =
select $
from $ \t -> do
where_ (t ^. TagId `in_` valList tag_ids)
return t
fetchTagColorsDB :: UserId -> DB (Map TagId Color)
fetchTagColorsDB user_id = fmap go $
select $
from $ \tc -> do
where_ (tc ^. TagColorUser ==. val user_id)
return tc
where
go :: [Entity TagColor] -> Map TagId Color
go = M.fromList . map ((tagColorTag &&& Color . tagColorColor) . entityVal)
fetchDefaultTagColorsDB :: DB (Map TagId Color)
fetchDefaultTagColorsDB = go <$> select (from return)
where
go :: [Entity DefaultTagColor] -> Map TagId Color
go =
M.fromList
. map (
(defaultTagColorTag &&& Color . defaultTagColorColor)
. entityVal)
-- | An tag 'annotated' with rendering information..
data AnnotatedTag = AnnotatedTag
{ annotTagTag :: Entity Tag
, annotTagUrl :: Route App
-- ^ The route to POST to (for changing votes).
, annotTagColor :: Color
, annotTagUserVotes :: [(Entity User, Int)]
}
annotTagName :: AnnotatedTag -> Text
annotTagName = tagName . entityVal . annotTagTag
{- Scoring for voting on tags is something not currently presented
- on the site. We've discussed changing it. I (Aaron) prefer a 6-point
- range voting just like we proposed for the Bylaws instead of mimicking
- the pledge formula here. Final decisions haven't been made yet -}
annotTagScore :: AnnotatedTag -> Double
annotTagScore =
sum
. map (\(_, x) ->
if x == 0
then 0
else fromIntegral
(signum x)
* logBase 2 (1 + fromIntegral (abs x) :: Double))
. annotTagUserVotes
annotTagUserScore :: AnnotatedTag -> UserId -> Maybe Int
annotTagUserScore at user_id =
fmap snd $ L.find ((== user_id) . entityKey . fst) $ annotTagUserVotes at
annotTagScoreString :: AnnotatedTag -> String
annotTagScoreString = printf "%.1f" . annotTagScore
sortAnnotTagsByName :: [AnnotatedTag] -> [AnnotatedTag]
sortAnnotTagsByName = sortBy (compare `on` annotTagName)
sortAnnotTagsByScore :: [AnnotatedTag] -> [AnnotatedTag]
sortAnnotTagsByScore = sortBy (compare `on` annotTagScore)
module Model.Transaction where
import Import
import qualified Data.Map as M
import Model.User
renderOtherAccount
:: Bool
-> Transaction
-> M.Map AccountId (Entity User)
-> M.Map AccountId (Entity Project)
-> Widget
renderOtherAccount is_credit transaction user_accounts project_accounts = do
let maybe_account_id = if is_credit
then transactionDebit transaction
else transactionCredit transaction
maybe_project =
maybe Nothing (`M.lookup` project_accounts) maybe_account_id
maybe_user = maybe Nothing (`M.lookup` user_accounts) maybe_account_id
toWidget $ case (maybe_project, maybe_user) of
(Just _, Just _) ->
error $
"account belongs to both a project and a user — "
<> "this shouldn't happen"
(Just (Entity _ project), Nothing) ->
[hamlet|
<a href=@{PHomeR (projectHandle project)}>
#{projectName project}
|]
(Nothing, Just (Entity user_id user)) ->
[hamlet|
<a href=@{UserR user_id}>
#{userDisplayName (Entity user_id user)}
|]
(Nothing, Nothing) ->
if is_credit
then
[hamlet|
deposited
|]
else
[hamlet|
withdrawn
|]
module Model.User.Sql
( exprUserIsModerator
, exprUserIsTeamMember
) where
import Import
exprUserIsModerator
:: UserId
-> SqlExpr (Value ProjectId)
-> SqlExpr (Value Bool)
exprUserIsModerator = exprHasRole Moderator
exprUserIsTeamMember
:: UserId
-> SqlExpr (Value ProjectId)
-> SqlExpr (Value Bool)
exprUserIsTeamMember = exprHasRole TeamMember
exprHasRole
:: Role
-> UserId
-> SqlExpr (Value ProjectId)
-> SqlExpr (Value Bool)
exprHasRole role user_id project_id =
exists $
from $ \r ->
where_ $
r ^. ProjectUserRoleProject ==. project_id &&.
r ^. ProjectUserRoleUser ==. val user_id &&.
r ^. ProjectUserRoleRole ==. val role
module Model.Utils where
import Import
import Blaze.ByteString.Builder (Builder, toLazyByteString)
import Control.Monad.Reader (MonadReader, ask)
import qualified Data.Map as M
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
routeToText :: MonadReader App m => Route App -> m Text
routeToText route = do
app <- ask
let (path_pieces, query_params) = renderRoute route
return (b2t (joinPath app "" path_pieces query_params))
where
b2t :: Builder -> Text
b2t = TL.toStrict . TLE.decodeUtf8 . toLazyByteString
-- This is not good, but its roots are deep.
lookupErr :: Ord k => String -> k -> Map k a -> a
lookupErr = M.findWithDefault . error
module Model.ViewType
( ViewType (..)
, viewTypeLabel
, viewTypeAbbrev
) where
import Import
import Model.ViewType.Internal
viewTypeLabel :: ViewType -> Text
viewTypeLabel ViewApplications = "ViewApplications"
viewTypeAbbrev :: ViewType -> Text
viewTypeAbbrev ViewApplications = "ViewApplications"
module View.Project.Signup where
import Import
hiding (ProjectSignupName
,ProjectSignupWebsite
,ProjectSignupHandle
,ProjectSignupStartDate
,ProjectSignupLocation
,ProjectSignupApplicantRole
,ProjectSignupMission
,ProjectSignupGoals
,ProjectSignupFundsUse
,ProjectSignupAdditionalInfo
,ProjectSignupLegalStatus
,ProjectSignupLegalStatusComment)
import Control.Applicative (liftA2)
import Data.Hourglass (timeGetDate, dateYear, Month (..))
import Data.String (fromString)
import System.Hourglass (timeCurrent)
import Text.Blaze.Internal (preEscapedText)
import qualified Data.Text as Text
import DeprecatedBootstrap
import Model.License.Internal
import Model.Project.Signup
import Model.Project.Signup.Internal
import Widgets.Markdown
projectSignupForm :: (Route App -> Text) -> [License] -> Form ProjectSignup
projectSignupForm render ls = renderBootstrap3 BootstrapBasicForm $ ProjectSignup
<$> reqc ProjectSignupName textField "Project name"
<*> optc ProjectSignupWebsite textField "Website"
<*> reqc ProjectSignupHandle textField
(fromString $ "Desired project handle (will be shown at " <>
handle <> ")")
<*> reqc ProjectSignupStartDate dateField "Project start date"
<*> reqn (multiSelectFieldList $ licenses ls)
"Project licenses (multiple can be selected)"
<*> optc ProjectSignupLicenseComment textField
"If other license, please describe"
<*> reqn (multiSelectFieldList categories)
"Primary project categories (multiple can be selected)"
<*> optc ProjectSignupCategoryComment textField
"Optional comments about project categories"
<*> optc ProjectSignupLocation textField
"Location project is legally based out of"
<*> reqn (selectFieldList legalStatuses) "Project legal status"
<*> optc ProjectSignupLegalStatusComment textField
"Optional details about legal status"
<*> reqn (selectFieldList coopStatuses)
"Are you structured or governed as a cooperative?"
<*> reqc ProjectSignupApplicantRole textField
"What role do you have with this project?"
<*> reqc ProjectSignupMission snowdriftMarkdownField
"What is your project's mission?"
<*> reqc ProjectSignupGoals snowdriftMarkdownField
"What are the project's goals in the near- and medium-term?"
<*> reqc ProjectSignupFundsUse snowdriftMarkdownField
(fromString $ "How will the project benefit from and " <>
"make use of funds raised through Snowdrift.coop?")
<*> optc ProjectSignupAdditionalInfo snowdriftMarkdownField
(fromString $ "Any additional comments, questions, or " <>
"information? Consider providing contact info for others " <>
"affiliated with the project")
where
handle = Text.unpack $ render $ PHomeR "handle"
dateField :: Field Handler (Year, Month)
dateField = Field
{ fieldParse = \rawVals _ ->
case rawVals of
[year, month] -> pair
(fieldParse yearsField [year] [])
(fieldParse monthsField [month] [])
[] -> return $ Right Nothing
_ -> return $ Left "You must enter two values"
, fieldView = \idAttr nameAttr otherAttrs eRes isReq -> do
asWidget "<div class=\"form-inline\">"
fieldView yearsField (idAttr <> "-year")
nameAttr otherAttrs (fst <$> eRes) isReq
fieldView monthsField (idAttr <> "-month")
nameAttr otherAttrs (snd <$> eRes) isReq
asWidget "</div>"
, fieldEnctype = UrlEncoded
}
where
asWidget = toWidget . preEscapedText . Text.pack
pair = (liftA2 . liftA2 . liftA2) (,)
yearsField = selectField years
monthsField = selectFieldList months
reqn :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> Field m a -> SomeMessage (HandlerSite m) -> AForm m a
reqn f s = areq' f s Nothing
optn :: MonadHandler m
=> Field m a -> SomeMessage (HandlerSite m) -> AForm m (Maybe a)
optn f s = aopt' f s Nothing
reqc :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage)
=> (a -> b) -> Field m a -> SomeMessage (HandlerSite m) -> AForm m b
reqc c f s = c <$> reqn f s
optc :: MonadHandler m
=> (a -> b) -> Field m a -> SomeMessage (HandlerSite m)
-> AForm m (Maybe b)
optc c f s = (c <$>) <$> optn f s
years :: Handler (OptionList Year)
years = do
current_year <- liftIO $ dateYear . timeGetDate <$> timeCurrent
optionsPairs $ map (\x -> (Text.pack $ show x, Year x))
[current_year, pred current_year .. 1980]
months :: [(Text, Month)]
months = map (\x -> (Text.pack $ show x, x)) $ enumFrom January
ppProjectCategory :: ProjectSignupCategory -> Text
ppProjectCategory CreativeWriting = "creative writing"
ppProjectCategory Education = "education"
ppProjectCategory Games = "games"
ppProjectCategory HardwareDesign = "hardware design"
ppProjectCategory Journalism = "journalism"
ppProjectCategory Music = "music"
ppProjectCategory OnlineService = "online service"
ppProjectCategory Research = "research"
ppProjectCategory Software = "software"
ppProjectCategory Video = "video"
ppProjectCategory VisualArt = "visual art"
ppProjectLegalStatus :: ProjectSignupLegalStatus -> Text
ppProjectLegalStatus NonProfitTaxDeductible =
"public-benefit with tax-deductible donations, as in 501(c)(3) in US"
ppProjectLegalStatus NonProfitNotTaxDeductible =
"other public-benefit status, such as 501(c)(4) and/or state-level designation"
ppProjectLegalStatus TradeOrganization =
"trade organization serving business interests, as in 501(c)(6)"
ppProjectLegalStatus ForProfitSocial =
"benefit corp or similar for-profit with added social mission"
ppProjectLegalStatus ForProfitTraditional = "traditional for-profit"
ppProjectLegalStatus Unincorporated = "unincorporated"
ppProjectCoopStatus :: ProjectSignupCoopStatus -> Text
ppProjectCoopStatus Coop = "yes"
ppProjectCoopStatus NotCoop = "no"
ppProjectSignupLicense :: ProjectSignupLicense -> Text
ppProjectSignupLicense (ProjectSignupLicense l) = unLicenseName $ licenseName l
ppProjectSignupLicense OtherProjectSignupLicense = "other"
licenses :: [License] -> [(Text, ProjectSignupLicense)]
licenses ls = flip map ls' $ \l -> (ppProjectSignupLicense l, l)
where
ls' = map ProjectSignupLicense ls <> [OtherProjectSignupLicense]
mapBounds :: (Enum b, Bounded b) => (b -> a) -> [(a, b)]
mapBounds f = flip map [minBound .. maxBound] $ \x -> (f x, x)
categories :: [(Text, ProjectSignupCategory)]
categories = mapBounds ppProjectCategory
legalStatuses :: [(Text, ProjectSignupLegalStatus)]
legalStatuses = mapBounds ppProjectLegalStatus
coopStatuses :: [(Text, ProjectSignupCoopStatus)]
coopStatuses = mapBounds ppProjectCoopStatus
{-# LANGUAGE OverloadedStrings #-}
module Widgets.Search
( searchForm
, searchFilterString
, searchSortString
) where
import Import
import qualified Data.Text as T