0votos

Acceso a edificio en Haskell

por josejuan hace 5 años

Claro que (siguiendo la solución anterior), también podemos crear un servicio RESTful CROSS domain que pueda ser atacado desde cualquier aplicación (no sólo websites), exponiendo adecuadamente los posibles mensajes de error que puedan producirse (incluído los mensajes que vengan del backend).

Controlar en php el acceso a un edificio

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, ScopedTypeVariables, NoMonomorphismRestriction, QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, FlexibleContexts, TemplateHaskell, OverloadedStrings, GADTs, MultiParamTypeClasses #-} 
import Yesod 
import GHC.Generics 
import Data.Maybe 
import Data.Either 
import Data.Aeson 
import Data.Text (pack, unpack) 
import Database.Persist.Sqlite 
import Control.Monad.Trans.Resource (runResourceT) 
import Control.Monad.Logger (runStderrLoggingT) 
import Oac 
 
data OacApp = OacApp { cnx :: ConnectionPool } 
 
instance Yesod OacApp 
 
instance YesodPersist OacApp where 
    type YesodPersistBackend OacApp = SqlPersistT 
    runDB action = getYesod >>= runSqlPool action . cnx 
 
mkYesod "OacApp" [parseRoutes|/ OacR POST|] 
 
data OacRequest = OacRequest { action   :: String 
                             , username :: String 
                             , password :: String 
                             , userdata :: Maybe (Entity User) 
                             } deriving (Show, Generic) 
 
instance FromJSON OacRequest 
instance ToJSON OacRequest 
 
postOacR :: Handler Value 
postOacR = do 
  addHeader "Access-Control-Allow-Origin" "*" 
  addHeader "Access-Control-Allow-Methods" "*" 
  jreq <- parseJsonBody 
  case jreq of 
    Error jreqErr -> invalidArgs ["Can't parse requested message", pack jreqErr] 
    Success req -> performOperation req >>= \ers -> 
                     case ers of 
                       Left msg -> invalidArgs ["Error in operation", pack msg] 
                       Right rs -> return rs 
 
 
performOperation (OacRequest action usr pwd udata) = do 
  let crs            = Credentials usr pwd 
      returnJSON i   = return . either Left (Right . toJSON . i) 
      Entity key val = fromJust udata 
  case action of 
    "listusers"  -> runDB $ adminSelect crs [] [] >>= returnJSON (id :: [Entity User] -> [Entity User]) 
    "insertuser" -> runDB $ adminInsert crs val   >>= returnJSON (id :: Key User -> Key User) 
    "deleteuser" -> runDB $ adminDelete crs key   >>= returnJSON (id :: () -> ()) 
    "updateuser" -> runDB $ adminUpdate crs key [ UserLogin    =. userLogin val 
                                                , UserPassword =. userPassword val 
                                                , UserAdmin    =. userAdmin val 
                                                ] >>= returnJSON (id :: () -> ()) 
    _            -> return $ Left $ "Invalid requested action `" ++ action ++ "`." 
     
main :: IO () 
main = withSqlitePool "oac.db3" 10 $ \p -> do 
         runResourceT $ runStderrLoggingT $ flip runSqlPool p $ runMigration migrateAll 
         warp 8181 $ OacApp p 

Comenta la solución

Tienes que identificarte para poder publicar tu comentario.